Tcl Library Source Code

Check-in [39bd8c6989]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2018 Conference, Houston/TX, US, Oct 15-19
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Aug 20.

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

Overview
Comment:Fixed the meta markup on the clay module. Moved the definition of clay::object into the metaclass.tcl file. This allows practcl to just steal the proc.tcl, class.tcl, and object.tcl files from this module to include on its own, without needing to ALSO include oo::dialect. Renamed the "source" ensemble method to "provenace" and added a new "source" which sources a file inside the object's namespace. Practcl now utilizes a minimalist snippet of the clay project, replacing its own implementation with the clay implementation.
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256:39bd8c698994bdb2cd00b94e7a2713214c6b65f4db834227dba29816e8008aca
User & Date: hypnotoad 2018-07-13 14:53:59
Context
2018-07-13
16:54
Removed dedicated variables for clay's delegation and mixinmap. (They are now sub-elements of the clay dict). Refactored the practcl clay implementation to provide a better mapping of old function calls. This new practcl version now runs old practcl projects unmodified. check-in: 0745c57cca user: hypnotoad tags: hypnotoad
14:53
Fixed the meta markup on the clay module. Moved the definition of clay::object into the metaclass.tcl file. This allows practcl to just steal the proc.tcl, class.tcl, and object.tcl files from this module to include on its own, without needing to ALSO include oo::dialect. Renamed the "source" ensemble method to "provenace" and added a new "source" which sources a file inside the object's namespace. Practcl now utilizes a minimalist snippet of the clay project, replacing its own implementation with the clay implementation. check-in: 39bd8c6989 user: hypnotoad tags: hypnotoad
2018-07-12
13:16
Fix to prevent oroburus loops in cron check-in: 8022922366 user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/clay/build/build.tcl.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
..
47
48
49
50
51
52
53
54
55
56

57
58
59
60
61
62
63
dict set map %module% $module
dict set map %version% $version

puts $fout [string map $map {
###
# clay.tcl
#
# Copyright (c) 2015-2018 Sean Woods
# Copyright (c) 2015 Donald K Fellows
#
# BSD License
###
# @@ Meta Begin
# Package %module% %version%
# Meta platform     tcl
# Meta summary      A utility for defining a domain specific language for TclOO systems
# Meta description  This package allows developers to generate
# Meta description  domain specific languages to describe TclOO
# Meta description  classes and objects.
# Meta category     TclOO
# Meta subject      metaclasses
# Meta require      {Tcl 8.6}
# Meta author       Sean Woods
# Meta author       Donald K. Fellows
# Meta license      BSD
# @@ Meta End
}]

puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
................................................................................
set loaded {}
lappend loaded build.tcl test.tcl

# These files must be loaded in a particular order
foreach file {
  core.tcl
  procs.tcl
  metaclass.tcl
  ensemble.tcl
  class.tcl

} {
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"







|
<






|
|
|
|

|


<







 







|
|
|
>







8
9
10
11
12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
..
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
dict set map %module% $module
dict set map %version% $version

puts $fout [string map $map {
###
# clay.tcl
#
# Copyright (c) 2018 Sean Woods

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

# Meta license      BSD
# @@ Meta End
}]

puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
................................................................................
set loaded {}
lappend loaded build.tcl test.tcl

# These files must be loaded in a particular order
foreach file {
  core.tcl
  procs.tcl
  class.tcl
  object.tcl
  metaclass.tcl
  ensemble.tcl
} {
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"

Changes to modules/clay/build/metaclass.tcl.

156
157
158
159
160
161
162
163
























































































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


































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
proc ::clay::object_destroy objname {
  if {$::clay::trace>0} {
    puts [list $objname DESTROY]
  }
  ::cron::object_destroy $objname
}


# clay::object
#
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  Variable organs {}
  Variable clay {}
  Variable mixinmap {}
  Variable claycache {}
  Variable DestroyEvent 0

  method Evolve {} {
    my Ensembles_Rebuild
  }

  method Ensembles_Rebuild {} {
    my variable clayorder clay claycache
    set claycache {}
    set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
    if {[info exists clay]} {
      set emap [dict getnull $clay method_ensemble/]
    } else {
      set emap {}
    }
    if {$::clay::trace>2} {
      puts "Rebuilding Ensembles"
    }
    foreach class $clayorder {
      foreach {var value} [$class clay get public/ variable/] {
        set var [string trim $var :/]
        if { $var in {clay} } continue
        my variable $var
        if {![info exists $var]} {
          if {$::clay::trace>2} {puts [list initialize variable $var $value]}
          set $var $value
        }
      }
      foreach {var value} [$class clay get public/ dict/] {
        set var [string trim $var :/]
        my variable $var
        if {![info exists $var]} { set $var {} }
        foreach {f v} $value {
          if {![dict exists ${var} $f]} {
            if {$::clay::trace>2} {puts [list initialize dict $var $f $v]}
            dict set ${var} $f $v
          }
        }
      }
      foreach {var value} [$class clay get public/ array/] {
        set var [string trim $var :/]
        if { $var eq {clay} } continue
        my variable $var
        if {![info exists $var]} { array set $var {} }
        foreach {f v} $value {
          if {![array exists ${var}($f)]} {
            if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]}
            set ${var}($f) $v
          }
        }
      }
      ###
      # Build a compsite map of all ensembles defined by the object's current
      # class as well as all of the classes being mixed in
      ###
      foreach {mensemble einfo} [$class clay get method_ensemble/] {
        set ensemble [string trim $mensemble :/]
        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}

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

Changes to modules/clay/build/object.tcl.

277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300






301
302
303
304
305
306
307
...
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
        foreach {item class} $mixinmap {
          if {$class ne {}} {
            lappend classlist $class
          }
        }
        my clay mixin {*}$classlist
      }
      replace {
        set clay [lindex $args 0]
      }
      script {
        source [lindex $args 0]
      }
      source {
        if {[dict exists $clay {*}$args]} {
          return self
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            return $class
          }
        }
        return {}
      }






      set {
        #puts [list [self] clay SET {*}$args]
        ::clay::dictmerge clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
................................................................................

  ###
  # React to a mixin
  ###
  method Evolve {} {}
}

# clay::object
#
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  Variable organs {}
  Variable clay {}
  Variable mixinmap {}
  Variable claycache {}
  Variable DestroyEvent 0

  method Evolve {} {
    my Ensembles_Rebuild
  }

  method Ensembles_Rebuild {} {
    my variable clayorder clay claycache
    set claycache {}
    set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
    if {[info exists clay]} {
      set emap [dict getnull $clay method_ensemble/]
    } else {
      set emap {}
    }
    if {$::clay::trace>2} {
      puts "Rebuilding Ensembles"
    }
    foreach class $clayorder {
      foreach {var value} [$class clay get public/ variable/] {
        set var [string trim $var :/]
        if { $var in {clay} } continue
        my variable $var
        if {![info exists $var]} {
          if {$::clay::trace>2} {puts [list initialize variable $var $value]}
          set $var $value
        }
      }
      foreach {var value} [$class clay get public/ dict/] {
        set var [string trim $var :/]
        my variable $var
        if {![info exists $var]} { set $var {} }
        foreach {f v} $value {
          if {![dict exists ${var} $f]} {
            if {$::clay::trace>2} {puts [list initialize dict $var $f $v]}
            dict set ${var} $f $v
          }
        }
      }
      foreach {var value} [$class clay get public/ array/] {
        set var [string trim $var :/]
        if { $var eq {clay} } continue
        my variable $var
        if {![info exists $var]} { array set $var {} }
        foreach {f v} $value {
          if {![array exists ${var}($f)]} {
            if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]}
            set ${var}($f) $v
          }
        }
      }
      ###
      # Build a compsite map of all ensembles defined by the object's current
      # class as well as all of the classes being mixed in
      ###
      foreach {mensemble einfo} [$class clay get method_ensemble/] {
        set ensemble [string trim $mensemble :/]
        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}

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







|
<
<
<
<
<
<










>
>
>
>
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
277
278
279
280
281
282
283
284






285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
...
310
311
312
313
314
315
316























































































        foreach {item class} $mixinmap {
          if {$class ne {}} {
            lappend classlist $class
          }
        }
        my clay mixin {*}$classlist
      }
      provenance {






        if {[dict exists $clay {*}$args]} {
          return self
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            return $class
          }
        }
        return {}
      }
      replace {
        set clay [lindex $args 0]
      }
      source {
        source [lindex $args 0]
      }
      set {
        #puts [list [self] clay SET {*}$args]
        ::clay::dictmerge clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
................................................................................

  ###
  # React to a mixin
  ###
  method Evolve {} {}
}
























































































Changes to modules/clay/build/test.tcl.

634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
...
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
...
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897

test clay-object-clay-a-0005 {Test the clay ancestors function} {
  $OBJ clay ancestors
} {::clay::object ::oo::object}
test clay-object-clay-a-0006 {Test the clay ancestors function} {
  $OBJ2 clay ancestors
} {::TEST::myclass ::clay::object ::oo::object}
test clay-object-clay-a-0007 {Test the clay source function} {
  $OBJ2 clay source flavor
} ::TEST::myclass

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

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

  clay color blue

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

###
# Test defining a standard method
###
test clay-object-method-0001 {Test and standard method} {
................................................................................
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}
test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::coloring.calico ::TEST::species.cat ::TEST::thing ::clay::object ::TEST::animal ::oo::object}

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

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







|
|










|







 







|
|




|
|

|







 







|







634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
...
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
...
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897

test clay-object-clay-a-0005 {Test the clay ancestors function} {
  $OBJ clay ancestors
} {::clay::object ::oo::object}
test clay-object-clay-a-0006 {Test the clay ancestors function} {
  $OBJ2 clay ancestors
} {::TEST::myclass ::clay::object ::oo::object}
test clay-object-clay-a-0007 {Test the clay provenance  function} {
  $OBJ2 clay provenance  flavor
} ::TEST::myclass

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

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

  clay color blue

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

###
# Test defining a standard method
###
test clay-object-method-0001 {Test and standard method} {
................................................................................
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}
test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::coloring.calico ::TEST::species.cat ::TEST::thing ::clay::object ::TEST::animal ::oo::object}

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

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

Changes to modules/clay/clay.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
...
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
...
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018






1019
1020
1021
1022
1023
1024
1025
....
1027
1028
1029
1030
1031
1032
1033










































































































































































1034
1035
1036
1037
1038
1039
1040
....
1116
1117
1118
1119
1120
1121
1122

1123
1124






































































































1125
1126
1127
1128
1129
1130

###
# clay.tcl
#
# Copyright (c) 2015-2018 Sean Woods
# Copyright (c) 2015 Donald K Fellows
#
# BSD License
###
# @@ Meta Begin
# Package clay 0.1
# Meta platform     tcl
# Meta summary      A utility for defining a domain specific language for TclOO systems
# Meta description  This package allows developers to generate
# Meta description  domain specific languages to describe TclOO
# Meta description  classes and objects.
# Meta category     TclOO
# Meta subject      metaclasses
# Meta require      {Tcl 8.6}
# Meta author       Sean Woods
# Meta author       Donald K. Fellows
# Meta license      BSD
# @@ Meta End

###
# Amalgamated package for clay
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
................................................................................
namespace eval ::clay {
  variable core_classes {::oo::class ::oo::object}
}

###
# END: procs.tcl
###
###
# START: metaclass.tcl
###
#-------------------------------------------------------------------------
# TITLE:
#    clay.tcl
#
# PROJECT:
#    clay: TclOO Helper Library
#
# DESCRIPTION:
#    clay(n): Implementation File
#
#-------------------------------------------------------------------------

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

::oo::dialect::create ::clay


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

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

###
# New OO Keywords for clay
###
proc ::clay::define::Array {name {values {}}} {
  set class [current_class]
  set name [string trim $name :/]/
  if {![$class clay exists array/ $name]} {
    $class clay set public/ array/ $name {}
  }
  foreach {var val} $values {
    $class clay set public/ array/ $name $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::clay::define::component {name info} {
  set class [current_class]
  foreach {field value} $info {
    $class clay set component/ [string trim $name :/]/ $field $value
  }
}

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

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

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

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

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

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

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

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

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



###
# END: metaclass.tcl
###
###
# START: ensemble.tcl
###
::namespace eval ::clay::define {}

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

  append mbody $preamble \n

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

::proc ::clay::define::Ensemble {rawmethod arglist body} {
  set class [current_class]
  if {$::clay::trace>2} {
    puts [list $class Ensemble $rawmethod $arglist $body]
  }
  set mlist [split $rawmethod "::"]
  set ensemble [string trim [lindex $mlist 0] :/]
  set mensemble ${ensemble}/
  if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} {
    set method _body
    ###
    # Simple method, needs no parsing, but we do need to record we have one
    ###
    $class clay set method_ensemble/ $mensemble _body [dict create arglist $arglist body $body]
    if {$::clay::trace>2} {
      puts [list $class clay set method_ensemble/ $mensemble _body ...]
    }
    set method $rawmethod
    if {$::clay::trace>2} {
      puts [list $class Ensemble $rawmethod $arglist $body]
      set rawbody $body
      set body {puts [list [self] $class [self method]]}
      append body \n $rawbody
    }
    ::oo::define $class method $rawmethod $arglist $body
    return
  }
  set method [join [lrange $mlist 2 end] "::"]
  $class clay set method_ensemble/ $mensemble [string trim $method :/] [dict create arglist $arglist body $body]
  if {$::clay::trace>2} {
    puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/]  ...]
  }
}

###
# END: ensemble.tcl
###
###
# START: class.tcl
###
oo::define oo::class {
  method clay {submethod args} {
    my variable clay
    if {![info exists clay]} {
................................................................................
        foreach {item class} $mixinmap {
          if {$class ne {}} {
            lappend classlist $class
          }
        }
        my clay mixin {*}$classlist
      }
      replace {
        set clay [lindex $args 0]
      }
      script {
        source [lindex $args 0]
      }
      source {
        if {[dict exists $clay {*}$args]} {
          return self
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            return $class
          }
        }
        return {}
      }






      set {
        #puts [list [self] clay SET {*}$args]
        ::clay::dictmerge clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
................................................................................
  }

  ###
  # React to a mixin
  ###
  method Evolve {} {}
}











































































































































































# clay::object
#
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  Variable organs {}
................................................................................
        append body \n $rawbody
      }
      oo::objdefine [self] method $ensemble {{method default} args} $body
    }
  }
}


###
# END: object.tcl






































































































###

namespace eval ::clay {
  namespace export *
}





|
<






|
|
|
|

|


<







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|
<
<
<
<
<
<










>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
...
374
375
376
377
378
379
380
















































































































































































































































































381
382
383
384
385
386
387
...
721
722
723
724
725
726
727
728






729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
...
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
....
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129

###
# clay.tcl
#
# Copyright (c) 2018 Sean Woods

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

# Meta license      BSD
# @@ Meta End

###
# Amalgamated package for clay
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
................................................................................
namespace eval ::clay {
  variable core_classes {::oo::class ::oo::object}
}

###
# END: procs.tcl
###
















































































































































































































































































###
# START: class.tcl
###
oo::define oo::class {
  method clay {submethod args} {
    my variable clay
    if {![info exists clay]} {
................................................................................
        foreach {item class} $mixinmap {
          if {$class ne {}} {
            lappend classlist $class
          }
        }
        my clay mixin {*}$classlist
      }
      provenance {






        if {[dict exists $clay {*}$args]} {
          return self
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            return $class
          }
        }
        return {}
      }
      replace {
        set clay [lindex $args 0]
      }
      source {
        source [lindex $args 0]
      }
      set {
        #puts [list [self] clay SET {*}$args]
        ::clay::dictmerge clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
................................................................................
  }

  ###
  # React to a mixin
  ###
  method Evolve {} {}
}


###
# END: object.tcl
###
###
# START: metaclass.tcl
###
#-------------------------------------------------------------------------
# TITLE:
#    clay.tcl
#
# PROJECT:
#    clay: TclOO Helper Library
#
# DESCRIPTION:
#    clay(n): Implementation File
#
#-------------------------------------------------------------------------

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

::oo::dialect::create ::clay


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

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

###
# New OO Keywords for clay
###
proc ::clay::define::Array {name {values {}}} {
  set class [current_class]
  set name [string trim $name :/]/
  if {![$class clay exists array/ $name]} {
    $class clay set public/ array/ $name {}
  }
  foreach {var val} $values {
    $class clay set public/ array/ $name $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::clay::define::component {name info} {
  set class [current_class]
  foreach {field value} $info {
    $class clay set component/ [string trim $name :/]/ $field $value
  }
}

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

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

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

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

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

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

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

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

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


# clay::object
#
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  Variable organs {}
................................................................................
        append body \n $rawbody
      }
      oo::objdefine [self] method $ensemble {{method default} args} $body
    }
  }
}


###
# END: metaclass.tcl
###
###
# START: ensemble.tcl
###
::namespace eval ::clay::define {}

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

  append mbody $preamble \n

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

::proc ::clay::define::Ensemble {rawmethod arglist body} {
  set class [current_class]
  if {$::clay::trace>2} {
    puts [list $class Ensemble $rawmethod $arglist $body]
  }
  set mlist [split $rawmethod "::"]
  set ensemble [string trim [lindex $mlist 0] :/]
  set mensemble ${ensemble}/
  if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} {
    set method _body
    ###
    # Simple method, needs no parsing, but we do need to record we have one
    ###
    $class clay set method_ensemble/ $mensemble _body [dict create arglist $arglist body $body]
    if {$::clay::trace>2} {
      puts [list $class clay set method_ensemble/ $mensemble _body ...]
    }
    set method $rawmethod
    if {$::clay::trace>2} {
      puts [list $class Ensemble $rawmethod $arglist $body]
      set rawbody $body
      set body {puts [list [self] $class [self method]]}
      append body \n $rawbody
    }
    ::oo::define $class method $rawmethod $arglist $body
    return
  }
  set method [join [lrange $mlist 2 end] "::"]
  $class clay set method_ensemble/ $mensemble [string trim $method :/] [dict create arglist $arglist body $body]
  if {$::clay::trace>2} {
    puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/]  ...]
  }
}

###
# END: ensemble.tcl
###

namespace eval ::clay {
  namespace export *
}

Changes to modules/clay/clay.test.

760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
...
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
....
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014

test clay-object-clay-a-0005 {Test the clay ancestors function} {
  $OBJ clay ancestors
} {::clay::object ::oo::object}
test clay-object-clay-a-0006 {Test the clay ancestors function} {
  $OBJ2 clay ancestors
} {::TEST::myclass ::clay::object ::oo::object}
test clay-object-clay-a-0007 {Test the clay source function} {
  $OBJ2 clay source flavor
} ::TEST::myclass

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

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

  clay color blue

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

###
# Test defining a standard method
###
test clay-object-method-0001 {Test and standard method} {
................................................................................
} {meow}
test clay-mixin-f-0003 {Test that an ensemble is created during a mixin}  -body {$OBJ which flavor} -returnCodes {error}  -result {unknown method which flavor. Valid: color sound}
test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::coloring.calico ::TEST::species.cat ::TEST::thing ::clay::object ::TEST::animal ::oo::object}

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

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







|
|










|







 







|
|




|
|

|







 







|







760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
...
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
....
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014

test clay-object-clay-a-0005 {Test the clay ancestors function} {
  $OBJ clay ancestors
} {::clay::object ::oo::object}
test clay-object-clay-a-0006 {Test the clay ancestors function} {
  $OBJ2 clay ancestors
} {::TEST::myclass ::clay::object ::oo::object}
test clay-object-clay-a-0007 {Test the clay provenance  function} {
  $OBJ2 clay provenance  flavor
} ::TEST::myclass

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

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

  clay color blue

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

###
# Test defining a standard method
###
test clay-object-method-0001 {Test and standard method} {
................................................................................
} {meow}
test clay-mixin-f-0003 {Test that an ensemble is created during a mixin}  -body {$OBJ which flavor} -returnCodes {error}  -result {unknown method which flavor. Valid: color sound}
test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::coloring.calico ::TEST::species.cat ::TEST::thing ::clay::object ::TEST::animal ::oo::object}

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

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

Changes to modules/practcl/build/build.tcl.

28
29
30
31
32
33
34

35
36
37
38
39
40
41
# These files must be loaded in a particular order

###
# Load other module code that this module will need
###
foreach {omod files} {
  httpwget wget.tcl

} {
  foreach fname $files {
    set file [file join $moddir .. $omod $fname]
    set fin [open $file r]
    puts $fout "###\n# START: [file join $omod $fname]\n###"
    puts $fout [read $fin]
    close $fin







>







28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
# These files must be loaded in a particular order

###
# Load other module code that this module will need
###
foreach {omod files} {
  httpwget wget.tcl
  clay {build/procs.tcl build/class.tcl build/object.tcl}
} {
  foreach fname $files {
    set file [file join $moddir .. $omod $fname]
    set fin [open $file r]
    puts $fout "###\n# START: [file join $omod $fname]\n###"
    puts $fout [read $fin]
    close $fin

Changes to modules/practcl/build/class/distro/baseclass.tcl.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
..
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
      scm  None
      hash {}
      maxdate {}
      tags {}
      isodate {}
    }
  }
  
  method DistroMixIn {} {
    my define set scm none
  }

  method Sandbox {} {
    if {[my define exists sandbox]} {
      return [my define get sandbox]
    }
    if {[my organ project] ni {::noop {}}} {
      set sandbox [my <project> define get sandbox]
      if {$sandbox ne {}} {
        my define set sandbox $sandbox
        return $sandbox
      }
    }
    set sandbox [file normalize [file join $::CWD ..]]
................................................................................

oo::objdefine ::practcl::distribution {

  method Sandbox {object} {
    if {[$object define exists sandbox]} {
      return [$object define get sandbox]
    }
    if {[$object organ project] ni {::noop {}}} {
      set sandbox [$object <project> define get sandbox]
      if {$sandbox ne {}} {
        $object define set sandbox $sandbox
        return $sandbox
      }
    }
    set pkg [$object define get name]
................................................................................
      $object define set srcdir $srcdir
    }

    set classprefix ::practcl::distribution.
    if {[file exists $srcdir]} {
      foreach class [::info commands ${classprefix}*] {
        if {[$class claim_path $srcdir]} {
          $object mixin distribution $class
          $object define set scm [string range $class [string length ::practcl::distribution.] end]
          return [$object define get scm]
        }
      }
    }
    foreach class [::info commands ${classprefix}*] {
      if {[$class claim_object $object]} {
        $object mixin distribution $class
        $object define set scm [string range $class [string length ::practcl::distribution.] end]
        return [$object define get scm]
      }
    }
    if {[$object define get scm] eq {} && [$object define exists file_url]} {
      set class ::practcl::distribution.snapshot
      $object define set scm snapshot
      $object mixin distribution $class
      return [$object define get scm]
    }
    error "Cannot determine source distribution method"
  }

  method claim_path path {
    return false
  }
  method claim_object object {
    return false
  }
}







|








|







 







|







 







|







|







|












11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
..
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
      scm  None
      hash {}
      maxdate {}
      tags {}
      isodate {}
    }
  }

  method DistroMixIn {} {
    my define set scm none
  }

  method Sandbox {} {
    if {[my define exists sandbox]} {
      return [my define get sandbox]
    }
    if {[my clay delegate project] ni {::noop {}}} {
      set sandbox [my <project> define get sandbox]
      if {$sandbox ne {}} {
        my define set sandbox $sandbox
        return $sandbox
      }
    }
    set sandbox [file normalize [file join $::CWD ..]]
................................................................................

oo::objdefine ::practcl::distribution {

  method Sandbox {object} {
    if {[$object define exists sandbox]} {
      return [$object define get sandbox]
    }
    if {[$object clay delegate project] ni {::noop {}}} {
      set sandbox [$object <project> define get sandbox]
      if {$sandbox ne {}} {
        $object define set sandbox $sandbox
        return $sandbox
      }
    }
    set pkg [$object define get name]
................................................................................
      $object define set srcdir $srcdir
    }

    set classprefix ::practcl::distribution.
    if {[file exists $srcdir]} {
      foreach class [::info commands ${classprefix}*] {
        if {[$class claim_path $srcdir]} {
          $object clay mixinmap distribution $class
          $object define set scm [string range $class [string length ::practcl::distribution.] end]
          return [$object define get scm]
        }
      }
    }
    foreach class [::info commands ${classprefix}*] {
      if {[$class claim_object $object]} {
        $object clay mixinmap distribution $class
        $object define set scm [string range $class [string length ::practcl::distribution.] end]
        return [$object define get scm]
      }
    }
    if {[$object define get scm] eq {} && [$object define exists file_url]} {
      set class ::practcl::distribution.snapshot
      $object define set scm snapshot
      $object clay mixinmap distribution $class
      return [$object define get scm]
    }
    error "Cannot determine source distribution method"
  }

  method claim_path path {
    return false
  }
  method claim_object object {
    return false
  }
}

Changes to modules/practcl/build/class/metaclass.tcl.

64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
...
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
...
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271





272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
      }
      default {
        array $submethod define {*}$args
      }
    }
  }


  method meta {submethod args} {
    my variable meta
    if {![info exists meta]} {
      set meta {}
    }
    switch $submethod {
      dump {
        return $meta
      }
      add {
        set field [lindex $args 0]
        if {![dict exists $meta $field]} {
          dict set meta $field {}
        }
        foreach arg [lrange $args 1 end] {
          if {$arg ni [dict get $meta $field]} {
            dict lappend meta $field $arg
          }
        }
        return [dict get $meta $field]
      }
      remove {
        set field [lindex $args 0]
        if {![dict exists meta $field]} {
          return
        }
        set rlist [lrange $args 1 end]
        set olist [dict get $meta $field]
        set nlist {}
        foreach arg $olist {
          if {$arg in $rlist} continue
          lappend nlist $arg
        }
        dict set meta $field $nlist
        return $nlist
      }
      exists {
        return [dict exists $meta {*}$args]
      }
      getnull -
      get {
        if {[dict exists $meta {*}$args]} {
          return [dict get $meta {*}$args]
        }
        return {}
      }
      cget {
        set field [lindex $args 0]
        if {[dict exists $meta $field]} {
          return [dict get $meta $field]
        }
        return [lindex $args 1]
      }
      set {
        if {[llength $args]==1} {
          foreach {field value} $args {
            dict set meta [string trimright $field :]: $value
          }
        } else {
          set field [lindex $args end-1]
          set value [lindex $args end]
          dict set meta {*}[lrange $args 0 end-2] [string trimright $field :]: $value
        }
      }
      default {
        error "Valid: add cget dump exists get getnull remove set"
      }
    }
  }
  
  method graft args {
    my variable organs
    if {[llength $args] == 1} {
      error "Need two arguments"
    }
    set object {}
    foreach {stub object} $args {
      dict set organs $stub $object
      oo::objdefine [self] forward <${stub}> $object
      oo::objdefine [self] export <${stub}>
    }
    return $object
  }

  method initialize {} {}


  method link {command args} {
    my variable links
    switch $command {
      object {
................................................................................
      } {
        if {[string match $pattern $class]} {
           set mixinslot $slot
           break
        }
      }
      if {$mixinslot ne {}} {
        my mixin $mixinslot $class
      } elseif {[info command $class] ne {}} {
        if {[info object class [self]] ne $class} {
          ::oo::objdefine [self] class $class
          ::practcl::debug [self] morph $class
           my define set class $class
        }
      } else {
................................................................................
    }
    if {[::info exists define(oodefine)]} {
      ::oo::objdefine [self] $define(oodefine)
      #unset define(oodefine)
    }
  }

  method mixin {slot classname} {
    my variable mixinslot
    set class {}
    set map [list @slot@ $slot @name@ $classname]
    foreach pattern [split [string map $map {
      @name@
      @slot@.@name@
      ::practcl::@name@
      ::practcl::@slot@.@name@
      ::practcl::@slot@*@name@
      ::practcl::*@name@*
    }] \n] {
      set pattern [string trim $pattern]
      set matches [info commands $pattern]
      if {![llength $matches]} continue
      set class [lindex $matches 0]
      break
    }





    ::practcl::debug [self] mixin $slot $class
    dict set mixinslot $slot $class
    set mixins {}
    foreach {s c} $mixinslot {
      if {$c eq {}} continue
      lappend mixins $c
    }
    oo::objdefine [self] mixin {*}$mixins
  }

  method organ {{stub all}} {
    my variable organs
    if {![info exists organs]} {
      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    if {[dict exists $organs $stub]} {
      return [dict get $organs $stub]
    }
  }

  method script script {
    eval $script
  }

  method select {} {
    my variable define
    if {[info exists define(class)]} {







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|







 







|
<
<












|
<

>
>
>
>
>










<
<
<
<
<
<
<
<
<
<
<
<
<







64
65
66
67
68
69
70





















































































71
72
73
74
75
76
77
...
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
...
162
163
164
165
166
167
168
169


170
171
172
173
174
175
176
177
178
179
180
181
182

183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198













199
200
201
202
203
204
205
      }
      default {
        array $submethod define {*}$args
      }
    }
  }






















































































  method initialize {} {}


  method link {command args} {
    my variable links
    switch $command {
      object {
................................................................................
      } {
        if {[string match $pattern $class]} {
           set mixinslot $slot
           break
        }
      }
      if {$mixinslot ne {}} {
        my clay mixin $mixinslot $class
      } elseif {[info command $class] ne {}} {
        if {[info object class [self]] ne $class} {
          ::oo::objdefine [self] class $class
          ::practcl::debug [self] morph $class
           my define set class $class
        }
      } else {
................................................................................
    }
    if {[::info exists define(oodefine)]} {
      ::oo::objdefine [self] $define(oodefine)
      #unset define(oodefine)
    }
  }

  method Practcl_Mixin_Pattern {slot classname} {


    set map [list @slot@ $slot @name@ $classname]
    foreach pattern [split [string map $map {
      @name@
      @slot@.@name@
      ::practcl::@name@
      ::practcl::@slot@.@name@
      ::practcl::@slot@*@name@
      ::practcl::*@name@*
    }] \n] {
      set pattern [string trim $pattern]
      set matches [info commands $pattern]
      if {![llength $matches]} continue
      return [lindex $matches 0]

    }
  }

  method mixin {slot classname} {
    my variable mixinslot
    set class [my Practcl_Mixin_Pattern $slot $classname]
    ::practcl::debug [self] mixin $slot $class
    dict set mixinslot $slot $class
    set mixins {}
    foreach {s c} $mixinslot {
      if {$c eq {}} continue
      lappend mixins $c
    }
    oo::objdefine [self] mixin {*}$mixins
  }














  method script script {
    eval $script
  }

  method select {} {
    my variable define
    if {[info exists define(class)]} {

Changes to modules/practcl/build/class/module.tcl.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
...
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
...
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
...
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
###
::oo::class create ::practcl::module {
  superclass ::practcl::object ::practcl::product.dynamic

  method _MorphPatterns {} {
    return {{@name@} {::practcl::module.@name@} ::practcl::module}
  }
  
  method add args {
    my variable links
    set object [::practcl::object new [self] {*}$args]
    foreach linktype [$object linktype] {
      lappend links($linktype) $object
    }
    return $object
  }
  
  
  method install-headers args {}
  
  ###
  # Target handling
  ###
  method make {command args} {
    my variable make_object
    if {![info exists make_object]} {
      set make_object {}
................................................................................
      }
      task -
      target -
      add {
        set name [lindex $args 0]
        set info [uplevel #0 [list subst [lindex $args 1]]]
        set body [lindex $args 2]
        
        set nspace [namespace current]
        if {[dict exist $make_object $name]} {
          set obj [dict get $$make_object $name]
        } else {
          set obj [::practcl::make_obj new [self] $name $info $body]
          dict set make_object $name $obj
          dict set target_make $name 0
................................................................................
        return $obj
      }
      todo {
         foreach {name obj} $make_object {
          if {[$obj do]} {
            lappend result $name
          }
        }       
      }
      do {
        global CWD SRCDIR project SANDBOX
        foreach {name obj} $make_object {
          if {[$obj do]} {
            eval [$obj define get action]
          }
        }
      }
    }
  }
  
  method child which {
    switch $which {
      organs {
        return [list project [my define get project] module [self]]
      }
    }
  }

 ###
  # This methods generates the contents of an amalgamated .c file
................................................................................
          lappend errs [dict get $errdat -errorinfo]
        } else {
          lappend errs $errdat
        }
      }
    }
    if {[llength $errs]} {
      set logfile [file join $::CWD practcl.log]      
      ::practcl::log $logfile "*** ERRORS ***"
      foreach {item trace} $errs {
        ::practcl::log $logfile "###\n# ERROR\n###\n$item"
       ::practcl::log $logfile "###\n# TRACE\n###\n$trace"
      }
      ::practcl::log $logfile "*** DEBUG INFO ***"
      ::practcl::log $logfile $::DEBUG_INFO







|








|
|

|







 







|







 







|











|


|







 







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
...
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
...
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
...
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
###
::oo::class create ::practcl::module {
  superclass ::practcl::object ::practcl::product.dynamic

  method _MorphPatterns {} {
    return {{@name@} {::practcl::module.@name@} ::practcl::module}
  }

  method add args {
    my variable links
    set object [::practcl::object new [self] {*}$args]
    foreach linktype [$object linktype] {
      lappend links($linktype) $object
    }
    return $object
  }


  method install-headers args {}

  ###
  # Target handling
  ###
  method make {command args} {
    my variable make_object
    if {![info exists make_object]} {
      set make_object {}
................................................................................
      }
      task -
      target -
      add {
        set name [lindex $args 0]
        set info [uplevel #0 [list subst [lindex $args 1]]]
        set body [lindex $args 2]

        set nspace [namespace current]
        if {[dict exist $make_object $name]} {
          set obj [dict get $$make_object $name]
        } else {
          set obj [::practcl::make_obj new [self] $name $info $body]
          dict set make_object $name $obj
          dict set target_make $name 0
................................................................................
        return $obj
      }
      todo {
         foreach {name obj} $make_object {
          if {[$obj do]} {
            lappend result $name
          }
        }
      }
      do {
        global CWD SRCDIR project SANDBOX
        foreach {name obj} $make_object {
          if {[$obj do]} {
            eval [$obj define get action]
          }
        }
      }
    }
  }

  method child which {
    switch $which {
      delegate {
        return [list project [my define get project] module [self]]
      }
    }
  }

 ###
  # This methods generates the contents of an amalgamated .c file
................................................................................
          lappend errs [dict get $errdat -errorinfo]
        } else {
          lappend errs $errdat
        }
      }
    }
    if {[llength $errs]} {
      set logfile [file join $::CWD practcl.log]
      ::practcl::log $logfile "*** ERRORS ***"
      foreach {item trace} $errs {
        ::practcl::log $logfile "###\n# ERROR\n###\n$item"
       ::practcl::log $logfile "###\n# TRACE\n###\n$trace"
      }
      ::practcl::log $logfile "*** DEBUG INFO ***"
      ::practcl::log $logfile $::DEBUG_INFO

Changes to modules/practcl/build/class/object.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
::oo::class create ::practcl::object {
  superclass ::practcl::metaclass

  constructor {parent args} {
    my variable links define
    set organs [$parent child organs]
    my graft {*}$organs
    array set define $organs
    array set define [$parent child define]
    array set links {}
    if {[llength $args]==1 && [file exists [lindex $args 0]]} {
      my define set filename [lindex $args 0]
      ::practcl::product select [self]
    } elseif {[llength $args] == 1} {
      set data  [uplevel 1 [list subst [lindex $args 0]]]





|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
::oo::class create ::practcl::object {
  superclass ::practcl::metaclass

  constructor {parent args} {
    my variable links define
    set delegates [$parent child delegate]
    my clay delegate {*}$delegates
    array set define $delegates
    array set define [$parent child define]
    array set links {}
    if {[llength $args]==1 && [file exists [lindex $args 0]]} {
      my define set filename [lindex $args 0]
      ::practcl::product select [self]
    } elseif {[llength $args] == 1} {
      set data  [uplevel 1 [list subst [lindex $args 0]]]

Changes to modules/practcl/build/class/product.tcl.

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
        }
      }
    }
    if {$class ne {}} {
      $object morph $class
    }
    if {$mixin ne {}} {
      $object mixin product $mixin
    }
  }
}

###
# Flesh out several trivial varieties of product
###







|







587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
        }
      }
    }
    if {$class ne {}} {
      $object morph $class
    }
    if {$mixin ne {}} {
      $object clay mixinmap product $mixin
    }
  }
}

###
# Flesh out several trivial varieties of product
###

Changes to modules/practcl/build/class/project/baseclass.tcl.

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
...
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
...
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
    # DEFS fields need to be passed unchanged and unsubstituted
    # as we need to preserve their escape characters
    foreach field {TCL_DEFS DEFS TK_DEFS} {
      if {[dict exists $rawcontents $field]} {
        dict set contents $field [dict get $rawcontents $field]
      }
    }
    my graft module [self]
    array set define $contents
    ::practcl::toolset select [self]
    my initialize
  }

  method add_object object {
    my link object $object
................................................................................
    }
    $tkobj define set config_opts $tk_config_opts
    $tkobj compile
  }

  method child which {
    switch $which {
      organs {
	# A library can be a project, it can be a module. Any
	# subordinate modules will indicate their existance
        return [list project [self] module [self]]
      }
    }
  }

................................................................................
      return $obj
    }
    ${obj} {*}$args
  }


  method tclcore {} {
    if {[info commands [set obj [my organ tclcore]]] ne {}} {
      return $obj
    }
    if {[info commands [set obj [my project TCLCORE]]] ne {}} {
      my graft tclcore $obj
      return $obj
    }
    if {[info commands [set obj [my project tcl]]] ne {}} {
      my graft tclcore $obj
      return $obj
    }
    if {[info commands [set obj [my tool tcl]]] ne {}} {
      my graft tclcore $obj
      return $obj
    }
    # Provide a fallback
    set obj [my add_tool tcl {
      tag release class subproject.core
      fossil_url http://core.tcl.tk/tcl
    }]
    my graft tclcore $obj
    return $obj
  }

  method tkcore {} {
    if {[set obj [my organ tkcore]] ne {}} {
      return $obj
    }
    if {[set obj [my project tk]] ne {}} {
      my graft tkcore $obj
      return $obj
    }
    if {[set obj [my tool tk]] ne {}} {
      my graft tkcore $obj
      return $obj
    }
    # Provide a fallback
    set obj [my add_tool tk {
      tag release class tool.core
      fossil_url http://core.tcl.tk/tk
    }]
    my graft tkcore $obj
    return $obj
  }

  method tool {pkg args} {
    set obj ::practcl::OBJECT::TOOL.$pkg
    if {[llength $args]==0} {
      return $obj
    }
    ${obj} {*}$args
  }
}







|







 







|







 







|



|



|



|







|




|


|
|



|







|











28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
...
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
...
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
    # DEFS fields need to be passed unchanged and unsubstituted
    # as we need to preserve their escape characters
    foreach field {TCL_DEFS DEFS TK_DEFS} {
      if {[dict exists $rawcontents $field]} {
        dict set contents $field [dict get $rawcontents $field]
      }
    }
    my clay delegate module [self]
    array set define $contents
    ::practcl::toolset select [self]
    my initialize
  }

  method add_object object {
    my link object $object
................................................................................
    }
    $tkobj define set config_opts $tk_config_opts
    $tkobj compile
  }

  method child which {
    switch $which {
      delegate {
	# A library can be a project, it can be a module. Any
	# subordinate modules will indicate their existance
        return [list project [self] module [self]]
      }
    }
  }

................................................................................
      return $obj
    }
    ${obj} {*}$args
  }


  method tclcore {} {
    if {[info commands [set obj [my clay delegate tclcore]]] ne {}} {
      return $obj
    }
    if {[info commands [set obj [my project TCLCORE]]] ne {}} {
      my clay delegate tclcore $obj
      return $obj
    }
    if {[info commands [set obj [my project tcl]]] ne {}} {
      my clay delegate tclcore $obj
      return $obj
    }
    if {[info commands [set obj [my tool tcl]]] ne {}} {
      my clay delegate tclcore $obj
      return $obj
    }
    # Provide a fallback
    set obj [my add_tool tcl {
      tag release class subproject.core
      fossil_url http://core.tcl.tk/tcl
    }]
    my clay delegate tclcore $obj
    return $obj
  }

  method tkcore {} {
    if {[set obj [my clay delegate tkcore]] ne {}} {
      return $obj
    }
    if {[set obj [my clay delegate tk]] ne {}} {
      my clay delegate tkcore $obj
      return $obj
    }
    if {[set obj [my tool tk]] ne {}} {
      my clay delegate tkcore $obj
      return $obj
    }
    # Provide a fallback
    set obj [my add_tool tk {
      tag release class tool.core
      fossil_url http://core.tcl.tk/tk
    }]
    my clay delegate tkcore $obj
    return $obj
  }

  method tool {pkg args} {
    set obj ::practcl::OBJECT::TOOL.$pkg
    if {[llength $args]==0} {
      return $obj
    }
    ${obj} {*}$args
  }
}

Changes to modules/practcl/build/class/subproject/baseclass.tcl.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

  method BuildDir {PWD} {
    return [my define get srcdir]
  }

  method child which {
    switch $which {
      organs {
	# A library can be a project, it can be a module. Any
	# subordinate modules will indicate their existance
        return [list project [self] module [self]]
      }
    }
  }








|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

  method BuildDir {PWD} {
    return [my define get srcdir]
  }

  method child which {
    switch $which {
      delegate {
	# A library can be a project, it can be a module. Any
	# subordinate modules will indicate their existance
        return [list project [self] module [self]]
      }
    }
  }

Changes to modules/practcl/build/class/target.tcl.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
..
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
    set triggered 0
    set domake 0
    set define(name) $name
    set define(action) {}
    array set define $info
    my select
    my initialize
    foreach {stub obj} [$module_object child organs] {
      my graft $stub $obj
    }
    if {$action_body ne {}} {
      set define(action) $action_body
    }
  }

  method do {} {
    my variable domake
................................................................................
        if {$filename ne {} && ![file exists $filename]} {
          set needs_make 1
        }
      }
    }
    return $needs_make
  }
  
  method output {} {
    set result {}
    set filename [my define get filename]
    if {$filename ne {}} {
      lappend result $filename
    }
    foreach filename [my define get files] {
................................................................................

  method reset {} {
    my variable triggered domake needs_make
    set triggerd 0
    set domake 0
    set needs_make 0
  }
  
  method triggers {} {
    my variable triggered domake define
    if {$triggered} {
      return $domake
    }
    set triggered 1
    set make_objects [my <module> make objects]







|
<
<







 







|







 







|







7
8
9
10
11
12
13
14


15
16
17
18
19
20
21
..
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
..
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
    set triggered 0
    set domake 0
    set define(name) $name
    set define(action) {}
    array set define $info
    my select
    my initialize
    my clay delegate {*}[$module_object child delegate]


    if {$action_body ne {}} {
      set define(action) $action_body
    }
  }

  method do {} {
    my variable domake
................................................................................
        if {$filename ne {} && ![file exists $filename]} {
          set needs_make 1
        }
      }
    }
    return $needs_make
  }

  method output {} {
    set result {}
    set filename [my define get filename]
    if {$filename ne {}} {
      lappend result $filename
    }
    foreach filename [my define get files] {
................................................................................

  method reset {} {
    my variable triggered domake needs_make
    set triggerd 0
    set domake 0
    set needs_make 0
  }

  method triggers {} {
    my variable triggered domake define
    if {$triggered} {
      return $domake
    }
    set triggered 1
    set make_objects [my <module> make objects]

Changes to modules/practcl/build/class/toolset/baseclass.tcl.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
...
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
oo::class create ::practcl::toolset {
  ###
  # find or fake a key/value list describing this project
  ###
  method config.sh {} {
    return [my read_configuration]
  }
  
  method BuildDir {PWD} {
    set name [my define get name]
    set debug [my define get debug 0]
    if {[my <project> define get LOCAL 0]} {
      return [my define get builddir [file join $PWD local $name]]
    }
    if {$debug} {
      return [my define get builddir [file join $PWD debug $name]]
    } else {
      return [my define get builddir [file join $PWD pkg $name]]
    }
  }
  
  method MakeDir {srcdir} {
    return $srcdir
  }
  
  method read_configuration {} {
    my variable conf_result
    if {[info exists conf_result]} {
      return $conf_result
    }
    set result {}
    set name [my define get name]
................................................................................
    }
    set srcdir [my SourceRoot]
    set PWD [pwd]
    cd $srcdir
    ::practcl::dotclexec $critcl {*}$args
    cd $PWD
  }
  
  method make-autodetect {} {}
}


oo::objdefine ::practcl::toolset {


................................................................................
    # Select the toolset to use for this project
    ###
    if {[$object define exists toolset]} {
      return [$object define get toolset]
    }
    set class [$object define get toolset]
    if {$class ne {}} {
      $object mixin toolset $class
    } else {
      if {[info exists ::env(VisualStudioVersion)]} {
        $object mixin toolset ::practcl::toolset.msvc
      } else {
        $object mixin toolset ::practcl::toolset.gcc
      }
    }
  }
}







|












|



|







 







|







 







|


|

|




6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
...
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
oo::class create ::practcl::toolset {
  ###
  # find or fake a key/value list describing this project
  ###
  method config.sh {} {
    return [my read_configuration]
  }

  method BuildDir {PWD} {
    set name [my define get name]
    set debug [my define get debug 0]
    if {[my <project> define get LOCAL 0]} {
      return [my define get builddir [file join $PWD local $name]]
    }
    if {$debug} {
      return [my define get builddir [file join $PWD debug $name]]
    } else {
      return [my define get builddir [file join $PWD pkg $name]]
    }
  }

  method MakeDir {srcdir} {
    return $srcdir
  }

  method read_configuration {} {
    my variable conf_result
    if {[info exists conf_result]} {
      return $conf_result
    }
    set result {}
    set name [my define get name]
................................................................................
    }
    set srcdir [my SourceRoot]
    set PWD [pwd]
    cd $srcdir
    ::practcl::dotclexec $critcl {*}$args
    cd $PWD
  }

  method make-autodetect {} {}
}


oo::objdefine ::practcl::toolset {


................................................................................
    # Select the toolset to use for this project
    ###
    if {[$object define exists toolset]} {
      return [$object define get toolset]
    }
    set class [$object define get toolset]
    if {$class ne {}} {
      $object clay mixinmap toolset [my Practcl_Mixin_Pattern toolset $class]
    } else {
      if {[info exists ::env(VisualStudioVersion)]} {
        $object clay mixinmap toolset ::practcl::toolset.msvc
      } else {
        $object clay mixinmap toolset ::practcl::toolset.gcc
      }
    }
  }
}

Changes to modules/practcl/practcl.tcl.

64
65
66
67
68
69
70

















































































































































































































































































































































































































































































































































































































































































































































71
72
73
74
75
76
77
....
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
....
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
....
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518





1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
....
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
....
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
....
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
....
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
....
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
....
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
....
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
....
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
....
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
....
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
....
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
....
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
....
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
....
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
....
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
....
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
....
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
....
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
....
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
    close $tmpchan
}


###
# END: httpwget/wget.tcl
###

















































































































































































































































































































































































































































































































































































































































































































































###
# START: setup.tcl
###
###
# Practcl
# An object oriented templating system for stamping out Tcl API calls to C
###
................................................................................
      }
      default {
        array $submethod define {*}$args
      }
    }
  }


  method meta {submethod args} {
    my variable meta
    if {![info exists meta]} {
      set meta {}
    }
    switch $submethod {
      dump {
        return $meta
      }
      add {
        set field [lindex $args 0]
        if {![dict exists $meta $field]} {
          dict set meta $field {}
        }
        foreach arg [lrange $args 1 end] {
          if {$arg ni [dict get $meta $field]} {
            dict lappend meta $field $arg
          }
        }
        return [dict get $meta $field]
      }
      remove {
        set field [lindex $args 0]
        if {![dict exists meta $field]} {
          return
        }
        set rlist [lrange $args 1 end]
        set olist [dict get $meta $field]
        set nlist {}
        foreach arg $olist {
          if {$arg in $rlist} continue
          lappend nlist $arg
        }
        dict set meta $field $nlist
        return $nlist
      }
      exists {
        return [dict exists $meta {*}$args]
      }
      getnull -
      get {
        if {[dict exists $meta {*}$args]} {
          return [dict get $meta {*}$args]
        }
        return {}
      }
      cget {
        set field [lindex $args 0]
        if {[dict exists $meta $field]} {
          return [dict get $meta $field]
        }
        return [lindex $args 1]
      }
      set {
        if {[llength $args]==1} {
          foreach {field value} $args {
            dict set meta [string trimright $field :]: $value
          }
        } else {
          set field [lindex $args end-1]
          set value [lindex $args end]
          dict set meta {*}[lrange $args 0 end-2] [string trimright $field :]: $value
        }
      }
      default {
        error "Valid: add cget dump exists get getnull remove set"
      }
    }
  }
  
  method graft args {
    my variable organs
    if {[llength $args] == 1} {
      error "Need two arguments"
    }
    set object {}
    foreach {stub object} $args {
      dict set organs $stub $object
      oo::objdefine [self] forward <${stub}> $object
      oo::objdefine [self] export <${stub}>
    }
    return $object
  }

  method initialize {} {}


  method link {command args} {
    my variable links
    switch $command {
      object {
................................................................................
      } {
        if {[string match $pattern $class]} {
           set mixinslot $slot
           break
        }
      }
      if {$mixinslot ne {}} {
        my mixin $mixinslot $class
      } elseif {[info command $class] ne {}} {
        if {[info object class [self]] ne $class} {
          ::oo::objdefine [self] class $class
          ::practcl::debug [self] morph $class
           my define set class $class
        }
      } else {
................................................................................
    }
    if {[::info exists define(oodefine)]} {
      ::oo::objdefine [self] $define(oodefine)
      #unset define(oodefine)
    }
  }

  method mixin {slot classname} {
    my variable mixinslot
    set class {}
    set map [list @slot@ $slot @name@ $classname]
    foreach pattern [split [string map $map {
      @name@
      @slot@.@name@
      ::practcl::@name@
      ::practcl::@slot@.@name@
      ::practcl::@slot@*@name@
      ::practcl::*@name@*
    }] \n] {
      set pattern [string trim $pattern]
      set matches [info commands $pattern]
      if {![llength $matches]} continue
      set class [lindex $matches 0]
      break
    }





    ::practcl::debug [self] mixin $slot $class
    dict set mixinslot $slot $class
    set mixins {}
    foreach {s c} $mixinslot {
      if {$c eq {}} continue
      lappend mixins $c
    }
    oo::objdefine [self] mixin {*}$mixins
  }

  method organ {{stub all}} {
    my variable organs
    if {![info exists organs]} {
      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    if {[dict exists $organs $stub]} {
      return [dict get $organs $stub]
    }
  }

  method script script {
    eval $script
  }

  method select {} {
    my variable define
    if {[info exists define(class)]} {
................................................................................
oo::class create ::practcl::toolset {
  ###
  # find or fake a key/value list describing this project
  ###
  method config.sh {} {
    return [my read_configuration]
  }
  
  method BuildDir {PWD} {
    set name [my define get name]
    set debug [my define get debug 0]
    if {[my <project> define get LOCAL 0]} {
      return [my define get builddir [file join $PWD local $name]]
    }
    if {$debug} {
      return [my define get builddir [file join $PWD debug $name]]
    } else {
      return [my define get builddir [file join $PWD pkg $name]]
    }
  }
  
  method MakeDir {srcdir} {
    return $srcdir
  }
  
  method read_configuration {} {
    my variable conf_result
    if {[info exists conf_result]} {
      return $conf_result
    }
    set result {}
    set name [my define get name]
................................................................................
    }
    set srcdir [my SourceRoot]
    set PWD [pwd]
    cd $srcdir
    ::practcl::dotclexec $critcl {*}$args
    cd $PWD
  }
  
  method make-autodetect {} {}
}


oo::objdefine ::practcl::toolset {


................................................................................
    # Select the toolset to use for this project
    ###
    if {[$object define exists toolset]} {
      return [$object define get toolset]
    }
    set class [$object define get toolset]
    if {$class ne {}} {
      $object mixin toolset $class
    } else {
      if {[info exists ::env(VisualStudioVersion)]} {
        $object mixin toolset ::practcl::toolset.msvc
      } else {
        $object mixin toolset ::practcl::toolset.gcc
      }
    }
  }
}

###
# END: class toolset baseclass.tcl
................................................................................
    set triggered 0
    set domake 0
    set define(name) $name
    set define(action) {}
    array set define $info
    my select
    my initialize
    foreach {stub obj} [$module_object child organs] {
      my graft $stub $obj
    }
    if {$action_body ne {}} {
      set define(action) $action_body
    }
  }

  method do {} {
    my variable domake
................................................................................
        if {$filename ne {} && ![file exists $filename]} {
          set needs_make 1
        }
      }
    }
    return $needs_make
  }
  
  method output {} {
    set result {}
    set filename [my define get filename]
    if {$filename ne {}} {
      lappend result $filename
    }
    foreach filename [my define get files] {
................................................................................

  method reset {} {
    my variable triggered domake needs_make
    set triggerd 0
    set domake 0
    set needs_make 0
  }
  
  method triggers {} {
    my variable triggered domake define
    if {$triggered} {
      return $domake
    }
    set triggered 1
    set make_objects [my <module> make objects]
................................................................................
# START: class object.tcl
###
::oo::class create ::practcl::object {
  superclass ::practcl::metaclass

  constructor {parent args} {
    my variable links define
    set organs [$parent child organs]
    my graft {*}$organs
    array set define $organs
    array set define [$parent child define]
    array set links {}
    if {[llength $args]==1 && [file exists [lindex $args 0]]} {
      my define set filename [lindex $args 0]
      ::practcl::product select [self]
    } elseif {[llength $args] == 1} {
      set data  [uplevel 1 [list subst [lindex $args 0]]]
................................................................................
        }
      }
    }
    if {$class ne {}} {
      $object morph $class
    }
    if {$mixin ne {}} {
      $object mixin product $mixin
    }
  }
}

###
# Flesh out several trivial varieties of product
###
................................................................................
###
::oo::class create ::practcl::module {
  superclass ::practcl::object ::practcl::product.dynamic

  method _MorphPatterns {} {
    return {{@name@} {::practcl::module.@name@} ::practcl::module}
  }
  
  method add args {
    my variable links
    set object [::practcl::object new [self] {*}$args]
    foreach linktype [$object linktype] {
      lappend links($linktype) $object
    }
    return $object
  }
  
  
  method install-headers args {}
  
  ###
  # Target handling
  ###
  method make {command args} {
    my variable make_object
    if {![info exists make_object]} {
      set make_object {}
................................................................................
      }
      task -
      target -
      add {
        set name [lindex $args 0]
        set info [uplevel #0 [list subst [lindex $args 1]]]
        set body [lindex $args 2]
        
        set nspace [namespace current]
        if {[dict exist $make_object $name]} {
          set obj [dict get $$make_object $name]
        } else {
          set obj [::practcl::make_obj new [self] $name $info $body]
          dict set make_object $name $obj
          dict set target_make $name 0
................................................................................
        return $obj
      }
      todo {
         foreach {name obj} $make_object {
          if {[$obj do]} {
            lappend result $name
          }
        }       
      }
      do {
        global CWD SRCDIR project SANDBOX
        foreach {name obj} $make_object {
          if {[$obj do]} {
            eval [$obj define get action]
          }
        }
      }
    }
  }
  
  method child which {
    switch $which {
      organs {
        return [list project [my define get project] module [self]]
      }
    }
  }

 ###
  # This methods generates the contents of an amalgamated .c file
................................................................................
          lappend errs [dict get $errdat -errorinfo]
        } else {
          lappend errs $errdat
        }
      }
    }
    if {[llength $errs]} {
      set logfile [file join $::CWD practcl.log]      
      ::practcl::log $logfile "*** ERRORS ***"
      foreach {item trace} $errs {
        ::practcl::log $logfile "###\n# ERROR\n###\n$item"
       ::practcl::log $logfile "###\n# TRACE\n###\n$trace"
      }
      ::practcl::log $logfile "*** DEBUG INFO ***"
      ::practcl::log $logfile $::DEBUG_INFO
................................................................................
    # DEFS fields need to be passed unchanged and unsubstituted
    # as we need to preserve their escape characters
    foreach field {TCL_DEFS DEFS TK_DEFS} {
      if {[dict exists $rawcontents $field]} {
        dict set contents $field [dict get $rawcontents $field]
      }
    }
    my graft module [self]
    array set define $contents
    ::practcl::toolset select [self]
    my initialize
  }

  method add_object object {
    my link object $object
................................................................................
    }
    $tkobj define set config_opts $tk_config_opts
    $tkobj compile
  }

  method child which {
    switch $which {
      organs {
	# A library can be a project, it can be a module. Any
	# subordinate modules will indicate their existance
        return [list project [self] module [self]]
      }
    }
  }

................................................................................
      return $obj
    }
    ${obj} {*}$args
  }


  method tclcore {} {
    if {[info commands [set obj [my organ tclcore]]] ne {}} {
      return $obj
    }
    if {[info commands [set obj [my project TCLCORE]]] ne {}} {
      my graft tclcore $obj
      return $obj
    }
    if {[info commands [set obj [my project tcl]]] ne {}} {
      my graft tclcore $obj
      return $obj
    }
    if {[info commands [set obj [my tool tcl]]] ne {}} {
      my graft tclcore $obj
      return $obj
    }
    # Provide a fallback
    set obj [my add_tool tcl {
      tag release class subproject.core
      fossil_url http://core.tcl.tk/tcl
    }]
    my graft tclcore $obj
    return $obj
  }

  method tkcore {} {
    if {[set obj [my organ tkcore]] ne {}} {
      return $obj
    }
    if {[set obj [my project tk]] ne {}} {
      my graft tkcore $obj
      return $obj
    }
    if {[set obj [my tool tk]] ne {}} {
      my graft tkcore $obj
      return $obj
    }
    # Provide a fallback
    set obj [my add_tool tk {
      tag release class tool.core
      fossil_url http://core.tcl.tk/tk
    }]
    my graft tkcore $obj
    return $obj
  }

  method tool {pkg args} {
    set obj ::practcl::OBJECT::TOOL.$pkg
    if {[llength $args]==0} {
      return $obj
................................................................................
      scm  None
      hash {}
      maxdate {}
      tags {}
      isodate {}
    }
  }
  
  method DistroMixIn {} {
    my define set scm none
  }

  method Sandbox {} {
    if {[my define exists sandbox]} {
      return [my define get sandbox]
    }
    if {[my organ project] ni {::noop {}}} {
      set sandbox [my <project> define get sandbox]
      if {$sandbox ne {}} {
        my define set sandbox $sandbox
        return $sandbox
      }
    }
    set sandbox [file normalize [file join $::CWD ..]]
................................................................................

oo::objdefine ::practcl::distribution {

  method Sandbox {object} {
    if {[$object define exists sandbox]} {
      return [$object define get sandbox]
    }
    if {[$object organ project] ni {::noop {}}} {
      set sandbox [$object <project> define get sandbox]
      if {$sandbox ne {}} {
        $object define set sandbox $sandbox
        return $sandbox
      }
    }
    set pkg [$object define get name]
................................................................................
      $object define set srcdir $srcdir
    }

    set classprefix ::practcl::distribution.
    if {[file exists $srcdir]} {
      foreach class [::info commands ${classprefix}*] {
        if {[$class claim_path $srcdir]} {
          $object mixin distribution $class
          $object define set scm [string range $class [string length ::practcl::distribution.] end]
          return [$object define get scm]
        }
      }
    }
    foreach class [::info commands ${classprefix}*] {
      if {[$class claim_object $object]} {
        $object mixin distribution $class
        $object define set scm [string range $class [string length ::practcl::distribution.] end]
        return [$object define get scm]
      }
    }
    if {[$object define get scm] eq {} && [$object define exists file_url]} {
      set class ::practcl::distribution.snapshot
      $object define set scm snapshot
      $object mixin distribution $class
      return [$object define get scm]
    }
    error "Cannot determine source distribution method"
  }

  method claim_path path {
    return false
................................................................................

  method BuildDir {PWD} {
    return [my define get srcdir]
  }

  method child which {
    switch $which {
      organs {
	# A library can be a project, it can be a module. Any
	# subordinate modules will indicate their existance
        return [list project [self] module [self]]
      }
    }
  }








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|







 







|
<
<












|
<

>
>
>
>
>










<
<
<
<
<
<
<
<
<
<
<
<
<







 







|












|



|







 







|







 







|


|

|







 







|
<
<







 







|







 







|







 







|
|
|







 







|







 







|








|
|

|







 







|







 







|











|


|







 







|







 







|







 







|







 







|



|



|



|







|




|


|
|



|







|







 







|








|







 







|







 







|







|







|







 







|







64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
....
2032
2033
2034
2035
2036
2037
2038





















































































2039
2040
2041
2042
2043
2044
2045
....
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
....
2130
2131
2132
2133
2134
2135
2136
2137


2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150

2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166













2167
2168
2169
2170
2171
2172
2173
....
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
....
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
....
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
....
3238
3239
3240
3241
3242
3243
3244
3245


3246
3247
3248
3249
3250
3251
3252
....
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
....
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
....
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
....
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
....
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
....
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
....
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
....
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
....
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
....
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
....
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
....
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
....
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
....
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
....
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
    close $tmpchan
}


###
# END: httpwget/wget.tcl
###
###
# START: clay/build/procs.tcl
###
###
# Global utilities
###
if {[info commands ::ladd] eq {}} {
  proc ladd {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        set var {}
    }
    foreach item $args {
      if {$item in $var} continue
      lappend var $item
    }
    return $var
  }
}

if {[info command ::ldelete] eq {}} {
  proc ::ldelete {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        return
    }
    foreach item [lsort -unique $args] {
      while {[set i [lsearch $var $item]]>=0} {
        set var [lreplace $var $i $i]
      }
    }
    return $var
  }
}

if {[info command ::lrandom] eq {}} {
  proc ::lrandom list {
    set len [llength $list]
    set idx [expr int(rand()*$len)]
    return [lindex $list $idx]
  }
}

if {[::info commands ::tcl::dict::getnull] eq {}} {
  proc ::tcl::dict::getnull {dictionary args} {
    if {[exists $dictionary {*}$args]} {
      get $dictionary {*}$args
    }
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
}

proc ::putb {buffername args} {
  upvar 1 $buffername buffer
  switch [llength $args] {
    1 {
      append buffer [lindex $args 0] \n
    }
    2 {
      append buffer [string map {*}$args] \n
    }
    default {
      error "usage: putb buffername ?map? string"
    }
  }
}
namespace eval ::clay {}

proc ::clay::ancestors args {
  set result {}
  set queue {}
  foreach class [lreverse $args] {
    lappend queue $class
  }

  # Rig things such that that the top superclasses
  # are evaluated first
  while {[llength $queue]} {
    set tqueue $queue
    set queue {}
    foreach qclass $tqueue {
      foreach aclass [::info class superclasses $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }
    }
    foreach item $tqueue {
      if { $item ni $result } {
        lappend result $item
      }
    }
  }
  return $result
}

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

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

proc ::clay::dictmerge {varname args} {
  upvar 1 $varname result
  if {![info exists result]} {
    set result {}
  }
  switch [llength $args] {
    0 {
      return
    }
    1 {
      set result [_dictmerge $result [lindex $args 0]]
      return $result
    }
    2 {
      lassign $args path value
    }
    default {
      # Merge b into a, and handle nested dicts appropriately
      set value [lindex $args end]
      set path  [lrange $args 0 end-1]
    }
  }
  if {![dict exists $result {*}$path]} {
    dict set result {*}$path $value
    return $result
  }
  if {[string index [lindex $path end] end] ne "/"} {
    dict set result {*}$path $value
    return $result
  }
  ::dict for { k v } $value {
    # Element names that end in "/" are assumed to be branches
    if {[string index $k end] eq "/" && [::dict exists $result {*}$path $k]} {
      # key exists in a and b?  let's see if both values are dicts
      # both are dicts, so merge the dicts
      set dvalue [::dict get $result {*}$path $k]
      if { [is_dict $dvalue] && [is_dict $v] } {
        ::dict set result {*}$path $k [_dictmerge $dvalue $v]
      } else {
        ::dict set result {*}$path $k $v
      }
    } else {
      ::dict set result {*}$path $k $v
    }
  }
  return $result
}

proc ::clay::_dictmerge {a b} {
  ::set result $a
  # Merge b into a, and handle nested dicts appropriately
  ::dict for { k v } $b {
    if {[string index $k end] ne "/"} {
      # Element names that do not end in "/" are assumed to be literals
      # or dict trees we intend to replace wholly
      ::dict set result $k $v
    } elseif { [::dict exists $result $k] } {
      # key exists in a and b?  let's see if both values are dicts
      # both are dicts, so merge the dicts
      if { [is_dict [::dict get $result $k]] && [is_dict $v] } {
        ::dict set result $k [_dictmerge [::dict get $result $k] $v]
      } else {
        ::dict set result $k $v
      }
    } else {
      ::dict set result $k $v
    }
  }
  return $result
}

proc ::clay::dictputb {dict} {
  set result {}
  set level -1
  _dictputb 0 $level result $dict
  return $result
}

proc ::clay::_dictputb {leaf level varname dict} {
  upvar 1 $varname result
  incr level
  foreach {field value} $dict {
    if {[string index $field end] eq "/"} {
      putb result "[string repeat "  " $level]$field \{"
      _dictputb 0 $level result $value
      putb result "[string repeat "  " $level]\}"
    } else {
      putb result "[string repeat "  " $level][list $field $value]"
    }
  }
}

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

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

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

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

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

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

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

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

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

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

###
# END: clay/build/procs.tcl
###
###
# START: clay/build/class.tcl
###
oo::define oo::class {
  method clay {submethod args} {
    my variable clay
    if {![info exists clay]} {
      set clay {}
    }
    switch $submethod {
      ancestors {
        tailcall ::clay::ancestors [self]
      }
      exists {
        set path [::clay::leaf {*}$args]
        if {![info exists clay]} {
          return 0
        }
        return [dict exists $clay {*}$path]
      }
      dump {
        return $clay
      }
      getnull -
      get {
        if {[llength $args]==0} {
          return $clay
        }
        if {![dict exists $clay {*}$args]} {
          return {}
        }
        tailcall dict get $clay {*}$args
      }
      merge {
        foreach arg $args {
          ::clay::dictmerge clay {*}$arg
        }
      }
      search {
        foreach aclass [::clay::ancestors [self]] {
          if {[$aclass clay exists {*}$args]} {
            return [$aclass clay get {*}$args]
          }
        }
      }
      set {
        #puts [list [self] clay SET {*}$args]
        set value [lindex $args end]
        set path [::clay::leaf {*}[lrange $args 0 end-1]]
        ::clay::dictmerge clay {*}$path $value
      }
      default {
        dict $submethod clay {*}$args
      }
    }
  }
}

###
# END: clay/build/class.tcl
###
###
# START: clay/build/object.tcl
###
oo::define oo::object {

  ###
  # title: Provide access to clay data
  # format: markdown
  # description:
  # The *clay* method allows an object access
  # to a combination of its own clay data as
  # well as to that of its class
  ###
  method clay {submethod args} {
    my variable clay claycache clayorder
    if {![info exists clay]} {set clay {}}
    if {![info exists claycache]} {set claycache {}}
    if {![info exists clayorder] || [llength $clayorder]==0} {
      set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
    }
    if {$::clay::trace > 1} {
      puts [list [info object class [self]] / [self] clay $submethod {*}$args]
    }
    switch $submethod {
      ancestors {
        return $clayorder
      }
      cget {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[dict exists $clay {*}$args]} {
          return [dict get $clay {*}$args]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$args]} {
          return [dict get $claycache {*}$args]
        }
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            set value [$class clay get {*}$args]
            dict set claycache {*}$args $value
            return $value
          }
          if {[$class clay exists const/ {*}$args]} {
            set value [$class clay get const/ {*}$args]
            dict set claycache {*}$args $value
            return $value
          }
          if {[llength $args]==1} {
            set field [lindex $args 0]
            if {[$class clay exists public/ option/ ${field}/ default]} {
              set value [$class clay get public/ option/ ${field}/ default]
              dict set claycache {*}$args $value
              return $value
            }
          }
        }
        return {}
      }
      delegate {
        my variable delegate
        if {![info exists delegate]} {
          set delegate {}
        }
        if {![dict exists delegate <class>]} {
          dict set delegate <class> [info object class [self]]
        }
        if {[llength $args]==0} {
          return $delegate
        }
        if {[llength $args]==1} {
          set stub <[string trim [lindex $args 0] <>]>
          if {![dict exists $delegate $stub]} {
            return {}
          }
          return [dict get $delegate $stub]
        }
        if {([llength $args] % 2)} {
          error "Usage: delegate
    OR
    delegate stub
    OR
    delegate stub OBJECT ?stub OBJECT? ..."
        }
        foreach {stub object} $args {
          set stub <[string trim $stub <>]>
          dict set delegate $stub $object
          oo::objdefine [self] forward ${stub} $object
          oo::objdefine [self] export ${stub}
        }
      }
      dump {
        # Do a full dump of clay data
        set result $clay
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          ::clay::dictmerge result [$class clay dump]
        }
        return $result
      }
      ensemble_map {
        set ensemble [lindex $args 0]
        my variable claycache
        set mensemble [string trim $ensemble :/]/
        if {[dict exists $claycache method_ensemble/ $mensemble]} {
          return [dict get $claycache method_ensemble/ $mensemble]
        }
        set emap [my clay get method_ensemble/ $mensemble]
        dict set claycache method_ensemble/ $mensemble $emap
        return $emap
      }
      eval {
        set script [lindex $args 0]
        set buffer {}
        set thisline {}
        foreach line [split $script \n] {
          append thisline $line
          if {![info complete $thisline]} {
            append thisline \n
            continue
          }
          set thisline [string trim $thisline]
          if {[string index $thisline 0] eq "#"} continue
          if {[string length $thisline]==0} continue
          if {[lindex $thisline 0] eq "my"} {
            # Line already calls out "my", accept verbatim
            append buffer $thisline \n
          } elseif {[string range $thisline 0 2] eq "::"} {
            # Fully qualified commands accepted verbatim
            append buffer $thisline \n
          } elseif {
            append buffer "my $thisline" \n
          }
          set thisline {}
        }
        eval $buffer
      }
      evolve {
        my Evolve
      }
      exists {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[dict exists $clay {*}$args]} {
          return 1
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$args]} {
          return 2
        }
        set count 2
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          incr count
          if {[$class clay exists {*}$args]} {
            return $count
          }
        }
        return 0
      }
      flush {
        set claycache {}
        set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
      }
      forward {
        oo::objdefine [self] forward {*}$args
      }
      getnull -
      get {
        set leaf [expr {[string index [lindex $args end] end] ne "/"}]
        #puts [list [self] clay get {*}$args (leaf: $leaf)]
        if {$leaf} {
          #puts [list EXISTS: (clay) [dict exists $clay {*}$args]]
          if {[dict exists $clay {*}$args]} {
            return [dict get $clay {*}$args]
          }
          # Search in our local cache
          #puts [list EXISTS: (claycache) [dict exists $claycache {*}$args]]
          if {[dict exists $claycache {*}$args]} {
            return [dict get $claycache {*}$args]
          }
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            if {[$class clay exists {*}$args]} {
              set value [$class clay get {*}$args]
              dict set claycache {*}$args $value
              return $value
            }
          }
        } else {
          set result {}
          # Leaf searches return one data field at a time
          # Search in our local dict
          if {[dict exists $clay {*}$args]} {
            set result [dict get $clay {*}$args]
          }
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::clay::dictmerge result [$class clay get {*}$args]
          }
          return $result
        }
      }
      leaf {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[dict exists $clay {*}$args]} {
          return [dict get $clay {*}$args]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$args]} {
          return [dict get $claycache {*}$args]
        }
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            set value [$class clay get {*}$args]
            dict set claycache {*}$args $value
            return $value
          }
        }
      }
      merge {
        foreach arg $args {
          ::clay::dictmerge clay {*}$arg
        }
      }
      mixin {
        ###
        # Mix in the class
        ###
        set prior  [info object mixins [self]]
        set newmixin {}
        foreach item $args {
          lappend newmixin ::[string trimleft $item :]
        }
        set newmap $args
        foreach class $prior {
          if {$class ni $newmixin} {
            set script [$class clay search mixin/ unmap-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
        ::oo::objdefine [self] mixin {*}$args
        ###
        # Build a compsite map of all ensembles defined by the object's current
        # class as well as all of the classes being mixed in
        ###
        my Evolve
        foreach class $newmixin {
          if {$class ni $prior} {
            set script [$class clay search mixin/ map-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
        foreach class $newmixin {
          set script [$class clay search mixin/ react-script]
          if {[string length $script]} {
            if {[catch $script err errdat]} {
              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
            }
            break
          }
        }
      }
      mixinmap {
        my variable mixinmap
        set priorlist {}
        foreach {slot classes} $args {
          dict set mixinmap $slot $classes
        }

        set classlist {}
        foreach {item class} $mixinmap {
          if {$class ne {}} {
            lappend classlist $class
          }
        }
        my clay mixin {*}$classlist
      }
      replace {
        set clay [lindex $args 0]
      }
      script {
        source [lindex $args 0]
      }
      source {
        if {[dict exists $clay {*}$args]} {
          return self
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            return $class
          }
        }
        return {}
      }
      set {
        #puts [list [self] clay SET {*}$args]
        ::clay::dictmerge clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
    }
  }

  ###
  # React to a mixin
  ###
  method Evolve {} {}
}


###
# END: clay/build/object.tcl
###
###
# START: setup.tcl
###
###
# Practcl
# An object oriented templating system for stamping out Tcl API calls to C
###
................................................................................
      }
      default {
        array $submethod define {*}$args
      }
    }
  }






















































































  method initialize {} {}


  method link {command args} {
    my variable links
    switch $command {
      object {
................................................................................
      } {
        if {[string match $pattern $class]} {
           set mixinslot $slot
           break
        }
      }
      if {$mixinslot ne {}} {
        my clay mixin $mixinslot $class
      } elseif {[info command $class] ne {}} {
        if {[info object class [self]] ne $class} {
          ::oo::objdefine [self] class $class
          ::practcl::debug [self] morph $class
           my define set class $class
        }
      } else {
................................................................................
    }
    if {[::info exists define(oodefine)]} {
      ::oo::objdefine [self] $define(oodefine)
      #unset define(oodefine)
    }
  }

  method Practcl_Mixin_Pattern {slot classname} {


    set map [list @slot@ $slot @name@ $classname]
    foreach pattern [split [string map $map {
      @name@
      @slot@.@name@
      ::practcl::@name@
      ::practcl::@slot@.@name@
      ::practcl::@slot@*@name@
      ::practcl::*@name@*
    }] \n] {
      set pattern [string trim $pattern]
      set matches [info commands $pattern]
      if {![llength $matches]} continue
      return [lindex $matches 0]

    }
  }

  method mixin {slot classname} {
    my variable mixinslot
    set class [my Practcl_Mixin_Pattern $slot $classname]
    ::practcl::debug [self] mixin $slot $class
    dict set mixinslot $slot $class
    set mixins {}
    foreach {s c} $mixinslot {
      if {$c eq {}} continue
      lappend mixins $c
    }
    oo::objdefine [self] mixin {*}$mixins
  }














  method script script {
    eval $script
  }

  method select {} {
    my variable define
    if {[info exists define(class)]} {
................................................................................
oo::class create ::practcl::toolset {
  ###
  # find or fake a key/value list describing this project
  ###
  method config.sh {} {
    return [my read_configuration]
  }

  method BuildDir {PWD} {
    set name [my define get name]
    set debug [my define get debug 0]
    if {[my <project> define get LOCAL 0]} {
      return [my define get builddir [file join $PWD local $name]]
    }
    if {$debug} {
      return [my define get builddir [file join $PWD debug $name]]
    } else {
      return [my define get builddir [file join $PWD pkg $name]]
    }
  }

  method MakeDir {srcdir} {
    return $srcdir
  }

  method read_configuration {} {
    my variable conf_result
    if {[info exists conf_result]} {
      return $conf_result
    }
    set result {}
    set name [my define get name]
................................................................................
    }
    set srcdir [my SourceRoot]
    set PWD [pwd]
    cd $srcdir
    ::practcl::dotclexec $critcl {*}$args
    cd $PWD
  }

  method make-autodetect {} {}
}


oo::objdefine ::practcl::toolset {


................................................................................
    # Select the toolset to use for this project
    ###
    if {[$object define exists toolset]} {
      return [$object define get toolset]
    }
    set class [$object define get toolset]
    if {$class ne {}} {
      $object clay mixinmap toolset [my Practcl_Mixin_Pattern toolset $class]
    } else {
      if {[info exists ::env(VisualStudioVersion)]} {
        $object clay mixinmap toolset ::practcl::toolset.msvc
      } else {
        $object clay mixinmap toolset ::practcl::toolset.gcc
      }
    }
  }
}

###
# END: class toolset baseclass.tcl
................................................................................
    set triggered 0
    set domake 0
    set define(name) $name
    set define(action) {}
    array set define $info
    my select
    my initialize
    my clay delegate {*}[$module_object child delegate]


    if {$action_body ne {}} {
      set define(action) $action_body
    }
  }

  method do {} {
    my variable domake
................................................................................
        if {$filename ne {} && ![file exists $filename]} {
          set needs_make 1
        }
      }
    }
    return $needs_make
  }

  method output {} {
    set result {}
    set filename [my define get filename]
    if {$filename ne {}} {
      lappend result $filename
    }
    foreach filename [my define get files] {
................................................................................

  method reset {} {
    my variable triggered domake needs_make
    set triggerd 0
    set domake 0
    set needs_make 0
  }

  method triggers {} {
    my variable triggered domake define
    if {$triggered} {
      return $domake
    }
    set triggered 1
    set make_objects [my <module> make objects]
................................................................................
# START: class object.tcl
###
::oo::class create ::practcl::object {
  superclass ::practcl::metaclass

  constructor {parent args} {
    my variable links define
    set delegates [$parent child delegate]
    my clay delegate {*}$delegates
    array set define $delegates
    array set define [$parent child define]
    array set links {}
    if {[llength $args]==1 && [file exists [lindex $args 0]]} {
      my define set filename [lindex $args 0]
      ::practcl::product select [self]
    } elseif {[llength $args] == 1} {
      set data  [uplevel 1 [list subst [lindex $args 0]]]
................................................................................
        }
      }
    }
    if {$class ne {}} {
      $object morph $class
    }
    if {$mixin ne {}} {
      $object clay mixinmap product $mixin
    }
  }
}

###
# Flesh out several trivial varieties of product
###
................................................................................
###
::oo::class create ::practcl::module {
  superclass ::practcl::object ::practcl::product.dynamic

  method _MorphPatterns {} {
    return {{@name@} {::practcl::module.@name@} ::practcl::module}
  }

  method add args {
    my variable links
    set object [::practcl::object new [self] {*}$args]
    foreach linktype [$object linktype] {
      lappend links($linktype) $object
    }
    return $object
  }


  method install-headers args {}

  ###
  # Target handling
  ###
  method make {command args} {
    my variable make_object
    if {![info exists make_object]} {
      set make_object {}
................................................................................
      }
      task -
      target -
      add {
        set name [lindex $args 0]
        set info [uplevel #0 [list subst [lindex $args 1]]]
        set body [lindex $args 2]

        set nspace [namespace current]
        if {[dict exist $make_object $name]} {
          set obj [dict get $$make_object $name]
        } else {
          set obj [::practcl::make_obj new [self] $name $info $body]
          dict set make_object $name $obj
          dict set target_make $name 0
................................................................................
        return $obj
      }
      todo {
         foreach {name obj} $make_object {
          if {[$obj do]} {
            lappend result $name
          }
        }
      }
      do {
        global CWD SRCDIR project SANDBOX
        foreach {name obj} $make_object {
          if {[$obj do]} {
            eval [$obj define get action]
          }
        }
      }
    }
  }

  method child which {
    switch $which {
      delegate {
        return [list project [my define get project] module [self]]
      }
    }
  }

 ###
  # This methods generates the contents of an amalgamated .c file
................................................................................
          lappend errs [dict get $errdat -errorinfo]
        } else {
          lappend errs $errdat
        }
      }
    }
    if {[llength $errs]} {
      set logfile [file join $::CWD practcl.log]
      ::practcl::log $logfile "*** ERRORS ***"
      foreach {item trace} $errs {
        ::practcl::log $logfile "###\n# ERROR\n###\n$item"
       ::practcl::log $logfile "###\n# TRACE\n###\n$trace"
      }
      ::practcl::log $logfile "*** DEBUG INFO ***"
      ::practcl::log $logfile $::DEBUG_INFO
................................................................................
    # DEFS fields need to be passed unchanged and unsubstituted
    # as we need to preserve their escape characters
    foreach field {TCL_DEFS DEFS TK_DEFS} {
      if {[dict exists $rawcontents $field]} {
        dict set contents $field [dict get $rawcontents $field]
      }
    }
    my clay delegate module [self]
    array set define $contents
    ::practcl::toolset select [self]
    my initialize
  }

  method add_object object {
    my link object $object
................................................................................
    }
    $tkobj define set config_opts $tk_config_opts
    $tkobj compile
  }

  method child which {
    switch $which {
      delegate {
	# A library can be a project, it can be a module. Any
	# subordinate modules will indicate their existance
        return [list project [self] module [self]]
      }
    }
  }

................................................................................
      return $obj
    }
    ${obj} {*}$args
  }


  method tclcore {} {
    if {[info commands [set obj [my clay delegate tclcore]]] ne {}} {
      return $obj
    }
    if {[info commands [set obj [my project TCLCORE]]] ne {}} {
      my clay delegate tclcore $obj
      return $obj
    }
    if {[info commands [set obj [my project tcl]]] ne {}} {
      my clay delegate tclcore $obj
      return $obj
    }
    if {[info commands [set obj [my tool tcl]]] ne {}} {
      my clay delegate tclcore $obj
      return $obj
    }
    # Provide a fallback
    set obj [my add_tool tcl {
      tag release class subproject.core
      fossil_url http://core.tcl.tk/tcl
    }]
    my clay delegate tclcore $obj
    return $obj
  }

  method tkcore {} {
    if {[set obj [my clay delegate tkcore]] ne {}} {
      return $obj
    }
    if {[set obj [my clay delegate tk]] ne {}} {
      my clay delegate tkcore $obj
      return $obj
    }
    if {[set obj [my tool tk]] ne {}} {
      my clay delegate tkcore $obj
      return $obj
    }
    # Provide a fallback
    set obj [my add_tool tk {
      tag release class tool.core
      fossil_url http://core.tcl.tk/tk
    }]
    my clay delegate tkcore $obj
    return $obj
  }

  method tool {pkg args} {
    set obj ::practcl::OBJECT::TOOL.$pkg
    if {[llength $args]==0} {
      return $obj
................................................................................
      scm  None
      hash {}
      maxdate {}
      tags {}
      isodate {}
    }
  }

  method DistroMixIn {} {
    my define set scm none
  }

  method Sandbox {} {
    if {[my define exists sandbox]} {
      return [my define get sandbox]
    }
    if {[my clay delegate project] ni {::noop {}}} {
      set sandbox [my <project> define get sandbox]
      if {$sandbox ne {}} {
        my define set sandbox $sandbox
        return $sandbox
      }
    }
    set sandbox [file normalize [file join $::CWD ..]]
................................................................................

oo::objdefine ::practcl::distribution {

  method Sandbox {object} {
    if {[$object define exists sandbox]} {
      return [$object define get sandbox]
    }
    if {[$object clay delegate project] ni {::noop {}}} {
      set sandbox [$object <project> define get sandbox]
      if {$sandbox ne {}} {
        $object define set sandbox $sandbox
        return $sandbox
      }
    }
    set pkg [$object define get name]
................................................................................
      $object define set srcdir $srcdir
    }

    set classprefix ::practcl::distribution.
    if {[file exists $srcdir]} {
      foreach class [::info commands ${classprefix}*] {
        if {[$class claim_path $srcdir]} {
          $object clay mixinmap distribution $class
          $object define set scm [string range $class [string length ::practcl::distribution.] end]
          return [$object define get scm]
        }
      }
    }
    foreach class [::info commands ${classprefix}*] {
      if {[$class claim_object $object]} {
        $object clay mixinmap distribution $class
        $object define set scm [string range $class [string length ::practcl::distribution.] end]
        return [$object define get scm]
      }
    }
    if {[$object define get scm] eq {} && [$object define exists file_url]} {
      set class ::practcl::distribution.snapshot
      $object define set scm snapshot
      $object clay mixinmap distribution $class
      return [$object define get scm]
    }
    error "Cannot determine source distribution method"
  }

  method claim_path path {
    return false
................................................................................

  method BuildDir {PWD} {
    return [my define get srcdir]
  }

  method child which {
    switch $which {
      delegate {
	# A library can be a project, it can be a module. Any
	# subordinate modules will indicate their existance
        return [list project [self] module [self]]
      }
    }
  }