TaoLib

Check-in [c0972ee07c]
Login

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

Overview
Comment:Updated clay and httpd from tcllib
Timelines: family | ancestors | clay
Files: files | file ages | folders
SHA1:c0972ee07cf5be78a893e24c6faa5dcd39e6e96a
User & Date: hypnotoad 2018-10-30 23:28:45
Context
2018-10-30
23:28
Updated clay and httpd from tcllib Leaf check-in: c0972ee07c user: hypnotoad tags: clay
2018-10-24
00:13
Replaced sak with Practcl installation manager check-in: 7c1b4765ca user: hypnotoad tags: clay
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/clay-db/build/schema.tcl.

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
  ###
  return [string compare -nocase $a $b]
}

::clay::define ::clay-db::meta.schema {
  Variable table_objs {}

  class_method schema args {
    if {[lindex $args 0] eq "<list>"} {
      return [my clay keys schema/]
    }
    return [my clay set schema/ {*}$args]
  }

  # Properties that need to be set:







|







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
  ###
  return [string compare -nocase $a $b]
}

::clay::define ::clay-db::meta.schema {
  Variable table_objs {}

  Class_Method schema args {
    if {[lindex $args 0] eq "<list>"} {
      return [my clay keys schema/]
    }
    return [my clay set schema/ {*}$args]
  }

  # Properties that need to be set:

Changes to modules/clay-db/clay-db.tcl.

54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
  ###
  return [string compare -nocase $a $b]
}

::clay::define ::clay-db::meta.schema {
  Variable table_objs {}

  class_method schema args {
    if {[lindex $args 0] eq "<list>"} {
      return [my clay keys schema/]
    }
    return [my clay set schema/ {*}$args]
  }

  # Properties that need to be set:







|







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
  ###
  return [string compare -nocase $a $b]
}

::clay::define ::clay-db::meta.schema {
  Variable table_objs {}

  Class_Method schema args {
    if {[lindex $args 0] eq "<list>"} {
      return [my clay keys schema/]
    }
    return [my clay set schema/ {*}$args]
  }

  # Properties that need to be set:

Changes to modules/clay-ui/build/baseclass.tcl.

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
    real     0
    number   0
    date     0
    complex  0
    boolean  0
  }

  class_method register {name body} {
    ::clay::define ::clay::ui::datatype::$name $body
    set ::clay::ui::datatype::regen 1
  }

  Option_Class organ {
    widget label
    set-command {my graft %field% %value%}







|







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
    real     0
    number   0
    date     0
    complex  0
    boolean  0
  }

  Class_Method register {name body} {
    ::clay::define ::clay::ui::datatype::$name $body
    set ::clay::ui::datatype::regen 1
  }

  Option_Class organ {
    widget label
    set-command {my graft %field% %value%}

Changes to modules/clay-ui/clay-ui.tcl.

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
    real     0
    number   0
    date     0
    complex  0
    boolean  0
  }

  class_method register {name body} {
    ::clay::define ::clay::ui::datatype::$name $body
    set ::clay::ui::datatype::regen 1
  }

  Option_Class organ {
    widget label
    set-command {my graft %field% %value%}







|







69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
    real     0
    number   0
    date     0
    complex  0
    boolean  0
  }

  Class_Method register {name body} {
    ::clay::define ::clay::ui::datatype::$name $body
    set ::clay::ui::datatype::regen 1
  }

  Option_Class organ {
    widget label
    set-command {my graft %field% %value%}

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

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# Track what files we have included so far
set loaded {}
lappend loaded build.tcl test.tcl

foreach {omod files} {
  uuid      {uuid.tcl}
  oodialect {oodialect.tcl}
  dicttool  {build/core.tcl build/dict.tcl build/list.tcl}
} {
  foreach file $files {
    set content [::practcl::cat [file join $moddir .. $omod {*}$file]]
    #AutoDoc scan_text $content
    puts $fout "###\n# START: [file join $omod $file]\n###"
    puts $fout [::practcl::docstrip $content]
    puts $fout "###\n# END: [file join $omod $file]\n###"







|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# Track what files we have included so far
set loaded {}
lappend loaded build.tcl test.tcl

foreach {omod files} {
  uuid      {uuid.tcl}
  oodialect {oodialect.tcl}
  dicttool  {dicttool.tcl}
} {
  foreach file $files {
    set content [::practcl::cat [file join $moddir .. $omod {*}$file]]
    #AutoDoc scan_text $content
    puts $fout "###\n# START: [file join $omod $file]\n###"
    puts $fout [::practcl::docstrip $content]
    puts $fout "###\n# END: [file join $omod $file]\n###"

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

1
2
3
4
5
6
7
8
9
10
11
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require TclOO
package require uuid
package require dicttool 1.2
package require oo::dialect

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

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


|
|
|






1
2
3
4
5
6
7
8
9
10
11
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require TclOO
#package require uuid
#package require dicttool 1.2
#package require oo::dialect

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

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

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

69
70
71
72
73
74
75
76
77








78
79
80
81
82
83
84
  }
  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} {







<
|
>
>
>
>
>
>
>
>







69
70
71
72
73
74
75

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
  }
  append body $rawbody
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###

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

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

proc ::clay::define::clay {args} {

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

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
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
...
311
312
313
314
315
316
317

318
319
320
321
322
323
324
...
335
336
337
338
339
340
341
342
343
344
345



346
347
348
349
350
351

352
353
354
355
356
357
358
...
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
...
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
  ###
  method clay {submethod args} {
    my variable clay claycache clayorder config option_canonical
    if {![info exists clay]} {set clay {}}
    if {![info exists claycache]} {set claycache {}}
    if {![info exists config]} {set config {}}
    if {![info exists clayorder] || [llength $clayorder]==0} {
      set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
    }
    switch $submethod {
      ancestors {
        return $clayorder
      }
      branch {
        set path [::dicttool::storage $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
      }
      dget {
        # Search in our local cache
        set path [::dicttool::storage $args]
        if {[llength $path]==0} {
          # Do a full dump of clay data
          set result {}
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::dicttool::dictmerge result [$class clay dump]
          }
          ::dicttool::dictmerge result $clay
          return $result
        }

        #if {[dict exists $claycache {*}$path]} {
        #  return [dict get $claycache {*}$path]
        #}
        if {[dict exists $clay {*}$path .]} {
          # Path is a branch
          set result {}
          foreach class [lreverse $clayorder] {
            if {[$class clay exists {*}$path .]} {
              set value [$class clay dget {*}$path]
              ::dicttool::dictmerge result $value
            }


          }
          ::dicttool::dictmerge result [dict get $clay {*}$path]
          dict set claycache {*}$path $result
          return $result
        } elseif {[dict exists $clay {*}$path]} {
          # Path is a leaf
          return [dict get $clay {*}$path]
        }
        # Search in the in our list of classes for an answer
        set found 0

        foreach class $clayorder {
          if {[$class clay exists {*}$path .]} {
            set found 1
            break
          }
          if {[$class clay exists {*}$path]} {
            # Found a leaf.
            set result [$class clay get {*}$path]
            dict set claycache {*}$path $result
            return $result
          }
        }
        set result {}
        if {$found} {
          # One of our ancestors has this as a branch
          # Do a recursive merge across all classes
          foreach class [lreverse $clayorder] {
            if {[$class clay exists {*}$path .]} {
              set value [$class clay dget {*}$path]
              ::dicttool::dictmerge result $value
            }
          }
        }
        dict set claycache {*}$path $result
        return $result
      }
      getnull -
      get {
        set path [::dicttool::storage $args]
        if {[llength $path]==0} {
................................................................................
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::dicttool::dictmerge result [$class clay dump]
          }
          ::dicttool::dictmerge result $clay
          return [::dicttool::sanitize $result]
        }

        if {[dict exists $claycache {*}$path .]} {
          return [::dicttool::sanitize [dict get $claycache {*}$path]]
        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
................................................................................
          if {!$branch && [$class clay exists {*}$path]} {
            set result [$class clay dget {*}$path]
            dict set claycache {*}$path $result
            return $result
          }
        }
        # Path is a branch
        set result {}
        foreach class [lreverse $clayorder] {
          if {[$class clay exists {*}$path .]} {
            set value [$class clay dget {*}$path]



            ::dicttool::dictmerge result $value
          }
        }
        if {[dict exists $clay {*}$path .]} {
          ::dicttool::dictmerge result [dict get $clay {*}$path]
        }

        dict set claycache {*}$path $result
        return [dicttool::sanitize $result]
      }
      leaf {
        # Leaf searches return one data field at a time
        # Search in our local dict
        set path [::dicttool::storage $args]
................................................................................
          dict set clay .mixin {}
        }
        if {[llength $args]==0} {
          return [dict get $clay .mixin]
        } elseif {[llength $args]==1} {
          return [dict getnull $clay .mixin [lindex $args 0]]
        } else {
          foreach {slot classes} $args {
            dict set clay .mixin $slot $classes
          }
          set claycache {}
          set classlist {}
          foreach {item class} [dict get $clay .mixin] {
            if {$class ne {}} {
              lappend classlist $class
            }
          }
          my clay mixin {*}[lreverse $classlist]
        }
      }
................................................................................

  ###
  # Instantiate variables. Called on object creation and during clay mixin.
  ###
  method InitializePublic {} {
    my variable clayorder clay claycache config option_canonical
    set claycache {}
    set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
    if {![info exists clay]} {
      set clay {}
    }
    if {![info exists config]} {
      set config {}
    }
    dict for {var value} [my clay get variable] {







|







 







|





<











>
|
|
<
<
<
<
<
<
<
<
|
>
>
|
<
<
<
|



<

>





|
<
|




|
|
|
|
|
|
|
|
|
<
<







 







>







 







|
|
|
|
>
>
>
|
|
<
|
|
<
>







 







|


<

|







 







|







75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
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
...
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
...
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
...
426
427
428
429
430
431
432
433
434
435

436
437
438
439
440
441
442
443
444
...
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
  ###
  method clay {submethod args} {
    my variable clay claycache clayorder config option_canonical
    if {![info exists clay]} {set clay {}}
    if {![info exists claycache]} {set claycache {}}
    if {![info exists config]} {set config {}}
    if {![info exists clayorder] || [llength $clayorder]==0} {
      set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
    }
    switch $submethod {
      ancestors {
        return $clayorder
      }
      branch {
        set path [::dicttool::storage $args]
................................................................................
            return $count
          }
        }
        return 0
      }
      flush {
        set claycache {}
        set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
      }
      forward {
        oo::objdefine [self] forward {*}$args
      }
      dget {

        set path [::dicttool::storage $args]
        if {[llength $path]==0} {
          # Do a full dump of clay data
          set result {}
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::dicttool::dictmerge result [$class clay dump]
          }
          ::dicttool::dictmerge result $clay
          return $result
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path .]} {
          return [dict get $claycache {*}$path]








        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }



        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
          # Path is a leaf
          return [dict get $clay {*}$path]
        }

        set found 0
        set branch [dict exists $clay {*}$path .]
        foreach class $clayorder {
          if {[$class clay exists {*}$path .]} {
            set found 1
            break
          }
          if {!$branch && [$class clay exists {*}$path]} {

            set result [$class clay dget {*}$path]
            dict set claycache {*}$path $result
            return $result
          }
        }
        # Path is a branch
        set result [dict getnull $clay {*}$path]
        foreach class $clayorder {
          if {![$class clay exists {*}$path .]} continue
          ::dicttool::dictmerge result [$class clay dget {*}$path]
        }
        #if {[dict exists $clay {*}$path .]} {
        #  ::dicttool::dictmerge result
        #}


        dict set claycache {*}$path $result
        return $result
      }
      getnull -
      get {
        set path [::dicttool::storage $args]
        if {[llength $path]==0} {
................................................................................
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::dicttool::dictmerge result [$class clay dump]
          }
          ::dicttool::dictmerge result $clay
          return [::dicttool::sanitize $result]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path .]} {
          return [::dicttool::sanitize [dict get $claycache {*}$path]]
        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
................................................................................
          if {!$branch && [$class clay exists {*}$path]} {
            set result [$class clay dget {*}$path]
            dict set claycache {*}$path $result
            return $result
          }
        }
        # Path is a branch
        set result [dict getnull $clay {*}$path]
        #foreach class [lreverse $clayorder] {
        #  if {![$class clay exists {*}$path .]} continue
        #  ::dicttool::dictmerge result [$class clay dget {*}$path]
        #}
        foreach class $clayorder {
          if {![$class clay exists {*}$path .]} continue
          ::dicttool::dictmerge result [$class clay dget {*}$path]
        }

        #if {[dict exists $clay {*}$path .]} {
        #  ::dicttool::dictmerge result [dict get $clay {*}$path]

        #}
        dict set claycache {*}$path $result
        return [dicttool::sanitize $result]
      }
      leaf {
        # Leaf searches return one data field at a time
        # Search in our local dict
        set path [::dicttool::storage $args]
................................................................................
          dict set clay .mixin {}
        }
        if {[llength $args]==0} {
          return [dict get $clay .mixin]
        } elseif {[llength $args]==1} {
          return [dict getnull $clay .mixin [lindex $args 0]]
        } else {
          dict for {slot classes} $args {
            dict set clay .mixin $slot $classes
          }

          set classlist {}
          dict for {item class} [dict get $clay .mixin] {
            if {$class ne {}} {
              lappend classlist $class
            }
          }
          my clay mixin {*}[lreverse $classlist]
        }
      }
................................................................................

  ###
  # Instantiate variables. Called on object creation and during clay mixin.
  ###
  method InitializePublic {} {
    my variable clayorder clay claycache config option_canonical
    set claycache {}
    set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
    if {![info exists clay]} {
      set clay {}
    }
    if {![info exists config]} {
      set config {}
    }
    dict for {var value} [my clay get variable] {

Changes to modules/clay/build/procs.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
29
30
31
32
namespace eval ::clay {}
set ::clay::trace 0












proc ::clay::ancestors args {
  set result {}
  set queue  [lreverse $args]
  set result $queue
  set metaclasses {}
  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
      }
    }




  }
  lappend result {*}$metaclasses

  ###
  # Screen out classes that do not participate in clay
  # interactions
  ###
  set output {}
  foreach {item} $result {
    if {[catch {$item clay noop} err]} {



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

|
<

<
<
<
>
|
<
>
>
>
>
>
|
<
<
>
>
>
>
>
>
|
|
<
<
>
|
|
|
>
>
>
>
|
<
>







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
29
30
31
32
33
34


35
36
37
38
39
40
41
42
43

44
45
46
47
48
49
50
51
namespace eval ::clay {}
set ::clay::trace 0

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

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

  set metaclasses {}




  foreach class $args {

    set ancestors($class) {}
    _ancestors ancestors($class) $class
  }
  foreach class [lreverse $args] {
    foreach aclass $ancestors($class) {
      if {$aclass in $result} continue


      set skip 0
      foreach bclass $args {
        if {$class eq $bclass} continue
        if {$aclass in $ancestors($bclass)} {
          set skip 1
          break
        }
      }


      if {$skip} continue
      lappend result $aclass
    }
  }
  foreach class [lreverse $args] {
    foreach aclass $ancestors($class) {
      if {$aclass in $result} continue
      lappend result $aclass
    }

  }
  ###
  # Screen out classes that do not participate in clay
  # interactions
  ###
  set output {}
  foreach {item} $result {
    if {[catch {$item clay noop} err]} {

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

27
28
29
30
31
32
33




34
35
36
37
38
39
40
41
42
43































































44
45
46
47
48
49
50
...
185
186
187
188
189
190
191



192
193
194



195
196
197
198
199
200
201
...
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
...
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
...
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
...
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
...
891
892
893
894
895
896
897

898
899
900
901

902
903
904
905
906
907
908
909
910
911
...
940
941
942
943
944
945
946

947
948
949
950
951

952
953
954
955
956
957
958
959
960
961
....
1022
1023
1024
1025
1026
1027
1028

1029
1030
1031

1032

1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
....
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
....
1399
1400
1401
1402
1403
1404
1405





























































































































































































































































































































































1406
1407
1408
1409
1410
1411
1412
set ::clay::trace 0
}


putb result {
# Modification History:
###




# Modification 2018-10-21
# The clay metaclass no longer exports the clay method
# to oo::class and oo::object, and clay::ancestors no
# longer returns any class that lacks the clay method
###
# Modification 2018-10-10
# clay::ancestors now rigged to descend into all classes depth-first
# and then place metaclasses at the end of the search
###
# -------------------------------------------------------------------------
































































::oo::dialect::create ::alpha

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

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




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



# Test canonical path building
set path {const/ foo/ bar/ baz/}
}
set testnum 0
foreach {pattern} {
  {const foo bar baz}
  {const/ foo/ bar/ baz}
................................................................................
    dict set map %object2% MIXINA

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

putb result {# -------------------------------------------------------------------------
................................................................................
    dict set map %object2% MIXINB

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

putb result {# -------------------------------------------------------------------------
# OBJECT descended from ::foo::classa ::foo::classb
set OBJECTAB [::foo::class.ab new]
# Object where classes were mixed in ::foo::classa ::foo::classb
set MIXINAB  [::oo::object new]

oo::objdefine $MIXINAB mixin ::foo::classa ::foo::classb
}
set matrix ${claydict-b}
foreach {top children} ${claydict-a} {
  foreach {child value} $children {
    if {![dict exists $matrix $top $child]} {
      dict set matrix $top $child $value
    }
................................................................................
    dict set map %object2% MIXINAB

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

putb result {# -------------------------------------------------------------------------
# OBJECT descended from ::foo::classb ::foo::classa
set OBJECTBA [::foo::class.ba new]
# Object where classes were mixed in ::foo::classb ::foo::classa
set MIXINBA  [::oo::object new]

oo::objdefine $MIXINBA mixin ::foo::classb ::foo::classa
}
set matrix ${claydict-a}
foreach {top children} ${claydict-b} {
  foreach {child value} $children {
    if {![dict exists $matrix $top $child]} {
      dict set matrix $top $child $value
    }
................................................................................
test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-e-0003 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}
###
# Test Modified: 2018-10-21, 2018-10-10
###
test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::species.cat ::TEST::thing ::TEST::animal ::clay::object}

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

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

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

###
# Test variable initialization
................................................................................
}

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


test clay-class-variable-0002 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get variable
} {DestroyEvent 0 my_variable 10}


test clay-class-variable-0003 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay dget variable
} {. {} DestroyEvent 0 my_variable 10}

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

###
# Test array initialization
................................................................................
  ::TEST::has_more_array clay get array
} {my_array {color blue}}

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


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


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

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

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


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



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

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

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

###
# Class method testing
###

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

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

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






























































































































































































































































































































































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

putb result {







>
>
>
>










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







 







>
>
>



>
>
>







 







|


|







 







|


|











>
|







 







|


|











>
|







 







|



|













|



|







 







>


|

>


|







 







>



|

>


|







 







>


<
>

>


|







 







|



|







 







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







27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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
...
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
...
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
...
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
...
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
...
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
...
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
....
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
....
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110

1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
....
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
....
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
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
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
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
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
set ::clay::trace 0
}


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

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

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

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

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

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

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


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

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

::oo::dialect::create ::alpha

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

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

}

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

}
putb result {
# Test canonical path building
set path {const/ foo/ bar/ baz/}
}
set testnum 0
foreach {pattern} {
  {const foo bar baz}
  {const/ foo/ bar/ baz}
................................................................................
    dict set map %object2% MIXINA

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

putb result {# -------------------------------------------------------------------------
................................................................................
    dict set map %object2% MIXINB

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

putb result {# -------------------------------------------------------------------------
# OBJECT descended from ::foo::classa ::foo::classb
set OBJECTAB [::foo::class.ab new]
# Object where classes were mixed in ::foo::classa ::foo::classb
set MIXINAB  [::oo::object new]
# Test modified 2018-10-30, mixin order was wrong before
oo::objdefine $MIXINAB mixin ::foo::classb ::foo::classa
}
set matrix ${claydict-b}
foreach {top children} ${claydict-a} {
  foreach {child value} $children {
    if {![dict exists $matrix $top $child]} {
      dict set matrix $top $child $value
    }
................................................................................
    dict set map %object2% MIXINAB

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

putb result {# -------------------------------------------------------------------------
# OBJECT descended from ::foo::classb ::foo::classa
set OBJECTBA [::foo::class.ba new]
# Object where classes were mixed in ::foo::classb ::foo::classa
set MIXINBA  [::oo::object new]
# Test modified 2018-10-30, mixin order was wrong before
oo::objdefine $MIXINBA mixin ::foo::classa ::foo::classb
}
set matrix ${claydict-a}
foreach {top children} ${claydict-b} {
  foreach {child value} $children {
    if {![dict exists $matrix $top $child]} {
      dict set matrix $top $child $value
    }
................................................................................
test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-e-0003 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}
###
# Test Modified: 2018-10-30, 2018-10-21, 2018-10-10
###
test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object}

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

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

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

###
# Test variable initialization
................................................................................
}

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

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

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

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

###
# Test array initialization
................................................................................
  ::TEST::has_more_array clay get array
} {my_array {color blue}}

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

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

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

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

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

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

} {my_dict {color blue timeout 10}}

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

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

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

###
# Class method testing
###

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

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

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

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

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


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

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

  method did {} {
    return MixinRoot
  }

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

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

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

  method did {} {
    return MixinOption1
  }

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

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

  clay set opts option option2

  Ensemble info::option {} {
    return MixinOption2
  }

  method did {} {
    return MixinOption2
  }

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


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

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

  method did {} {
    return MixinColor1
  }

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

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

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

  method did {} {
    return MixinColor2
  }

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

set obj [clay::object new]

$obj clay mixinmap root ::MixinRoot
}
set testnum 0
set batnum  0

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

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

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

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

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

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

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

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

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

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

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

putb result {

Deleted modules/clay/clay.man.

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

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

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

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

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

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

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

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


[section {Commands}]
[list_begin definitions]
[call proc [cmd clay::ancestors] [opt "[arg args]"]]


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


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


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



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



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


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


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


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


[call proc [cmd clay::script_path]]


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


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


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


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


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

 New OO Keywords for clay




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

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




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



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



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


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



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


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

 Define an option for the class




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

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




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

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




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


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


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


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


[call proc [cmd clay::define::Ensemble] [arg rawmethod] [arg arglist] [arg body]]


[list_end]

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

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

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

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

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

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

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

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

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

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

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

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

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

[list_end]
[para]

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

 This class is inherited by all classes that have options.



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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

[call method [cmd "InitializePublic"]]

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




[list_end]
[para]

[section AUTHORS]
Sean Woods [uri mailto:<yoda@etoyoc.com>][para]
[vset CATEGORY oo]
[include ../doctools2base/include/feedback.inc]

[manpage_end]

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


















































































































































































































































































































































































































































































































































































































































































































































































































































Changes to modules/httpd/build/file.tcl.

2
3
4
5
6
7
8




9
10
11
12
13
14
15
# Class to deliver Static content
# When utilized, this class is fed a local filename
# by the dispatcher
###
::clay::define ::httpd::content.file {

  method FileName {} {




    set uri [string trimleft [my request get REQUEST_URI] /]
    set path [my clay get path]
    set prefix [my clay get prefix]
    set fname [string range $uri [string length $prefix] end]
    if {$fname in "{} index.html index.md index index.tml"} {
      return $path
    }







>
>
>
>







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# Class to deliver Static content
# When utilized, this class is fed a local filename
# by the dispatcher
###
::clay::define ::httpd::content.file {

  method FileName {} {
    # Some dispatchers will inject a fully qualified name during discovery
    if {[my clay exists FILENAME] && [file exists [my clay get FILENAME]]} {
      return [my clay get FILENAME]
    }
    set uri [string trimleft [my request get REQUEST_URI] /]
    set path [my clay get path]
    set prefix [my clay get prefix]
    set fname [string range $uri [string length $prefix] end]
    if {$fname in "{} index.html index.md index index.tml"} {
      return $path
    }