Tcl Library Source Code

Check-in [ab481a1f5b]
Login
Core Home Blog Docs Downloads Tickets Timeline Branches Tags Wiki
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:Shifting standard HTTP fields out of the root of clay, and into the http leaf. Redirecting API calls to not ask directly from clay what it expected as an HTTP header, and instead use the "request" method. Bumped versions of clay and httpd to denote they are fundimentally new versions. Changes to Clay: Changed the "Evolve" method in Clay to the "InitializePublic" to match Tool and what OOmeta expects. While clay itself doesn't utilize options, it's initializers are aware of how they will be annotated by future versions of tool/tao Moved variable, array, and dict annotations out of the public/ branch and into their own roots. Mixin is now a leaf in the clay tree. Added more tests to clay Changes to httpd: Replaced calls to http_info with naked calls to the clay data structure. Explicit requests for HTTP header info now directed at the request method. Request now stores headers with CGI/SCGI comadible names. Changes to practcl: Minor fixups from clay changes.
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256:ab481a1f5bc6fc3ab7704ffc37871c03ae17f1277cdaf22a43bd1603f5508d2e
User & Date: hypnotoad 2018-09-07 14:27:34
Context
2018-09-08
18:56
Httpd module: Fixed a goof in redirect handlers. Fixed which headers are accessed for logging. Added a shim for web servers to provide a standard style mixin. Added a shim for servers to participate with their own private methods prior and following mixin dispatch. Added a hook for server to provide a local method for Headers check-in: d20a51f758 user: hypnotoad tags: hypnotoad
2018-09-07
14:27
Shifting standard HTTP fields out of the root of clay, and into the http leaf. Redirecting API calls to not ask directly from clay what it expected as an HTTP header, and instead use the "request" method. Bumped versions of clay and httpd to denote they are fundimentally new versions. Changes to Clay: Changed the "Evolve" method in Clay to the "InitializePublic" to match Tool and what OOmeta expects. While clay itself doesn't utilize options, it's initializers are aware of how they will be annotated by future versions of tool/tao Moved variable, array, and dict annotations out of the public/ branch and into their own roots. Mixin is now a leaf in the clay tree. Added more tests to clay Changes to httpd: Replaced calls to http_info with naked calls to the clay data structure. Explicit requests for HTTP header info now directed at the request method. Request now stores headers with CGI/SCGI comadible names. Changes to practcl: Minor fixups from clay changes. check-in: ab481a1f5b user: hypnotoad tags: hypnotoad
2018-08-28
14:15
Updating man pages to reflect change to clay framework check-in: 4aa8790961 user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to embedded/www/tcllib/files/modules/httpd/httpd.html. 

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
...
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427

<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
<li class="doctools_section"><a href="#section1">Description</a></li>
<li class="doctools_section"><a href="#section2">Minimal Example</a></li>
<li class="doctools_section"><a href="#section3">Class ::httpd::server</a></li>
<li class="doctools_section"><a href="#section4">Class ::httpd::reply</a></li>
<li class="doctools_section"><a href="#section5">Reply Method Ensembles</a></li>
<li class="doctools_section"><a href="#section6">Reply Method Ensemble: http_info</a></li>
<li class="doctools_section"><a href="#section7">Reply Method Ensemble: request</a></li>
<li class="doctools_section"><a href="#section8">Reply Method Ensemble: reply</a></li>
<li class="doctools_section"><a href="#section9">Reply Methods</a></li>
<li class="doctools_section"><a href="#section10">Class ::httpd::content</a></li>
<li class="doctools_section"><a href="#section11">Class ::httpd::content.cgi</a></li>
<li class="doctools_section"><a href="#section12">Class ::httpd::content.file</a></li>
<li class="doctools_section"><a href="#section13">Class ::httpd::content.proxy</a></li>
................................................................................
tool::define ::test::content.file {
	superclass ::httpd::content.file
	# Return a file
	# Note: this is using the content.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my http_info get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index.html]
	}
}
tool::define ::test::content.time {
  # return the current system time
	method content {} {
................................................................................
    my puts &quot;You Sent&lt;p&gt;&quot;
    my puts &quot;&lt;TABLE&gt;&quot;
    foreach {f v} $form {
      my puts &quot;&lt;TR&gt;&lt;TH&gt;$f&lt;/TH&gt;&lt;TD&gt;&lt;verbatim&gt;$v&lt;/verbatim&gt;&lt;/TD&gt;&quot;
    }
    my puts &quot;&lt;/TABLE&gt;&lt;p&gt;&quot;
    my puts &quot;Send some info:&lt;p&gt;&quot;
    my puts &quot;&lt;FORM action=/[my http_info get REQUEST_PATH] method POST&gt;&quot;
    my puts &quot;&lt;TABLE&gt;&quot;
    foreach field {name rank serial_number} {
      set line &quot;&lt;TR&gt;&lt;TH&gt;$field&lt;/TH&gt;&lt;TD&gt;&lt;input name=\&quot;$field\&quot; &quot;
      if {[dict exists $form $field]} {
        append line &quot; value=\&quot;[dict get $form $field]\&quot;&quot;&quot;
      }
      append line &quot; /&gt;&lt;/TD&gt;&lt;/TR&gt;&quot;








|







 







|







 







|








108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
...
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427

<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
<li class="doctools_section"><a href="#section1">Description</a></li>
<li class="doctools_section"><a href="#section2">Minimal Example</a></li>
<li class="doctools_section"><a href="#section3">Class ::httpd::server</a></li>
<li class="doctools_section"><a href="#section4">Class ::httpd::reply</a></li>
<li class="doctools_section"><a href="#section5">Reply Method Ensembles</a></li>
<li class="doctools_section"><a href="#section6">Reply Method Ensemble: clay</a></li>
<li class="doctools_section"><a href="#section7">Reply Method Ensemble: request</a></li>
<li class="doctools_section"><a href="#section8">Reply Method Ensemble: reply</a></li>
<li class="doctools_section"><a href="#section9">Reply Methods</a></li>
<li class="doctools_section"><a href="#section10">Class ::httpd::content</a></li>
<li class="doctools_section"><a href="#section11">Class ::httpd::content.cgi</a></li>
<li class="doctools_section"><a href="#section12">Class ::httpd::content.file</a></li>
<li class="doctools_section"><a href="#section13">Class ::httpd::content.proxy</a></li>
................................................................................
tool::define ::test::content.file {
	superclass ::httpd::content.file
	# Return a file
	# Note: this is using the content.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my clay get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index.html]
	}
}
tool::define ::test::content.time {
  # return the current system time
	method content {} {
................................................................................
    my puts &quot;You Sent&lt;p&gt;&quot;
    my puts &quot;&lt;TABLE&gt;&quot;
    foreach {f v} $form {
      my puts &quot;&lt;TR&gt;&lt;TH&gt;$f&lt;/TH&gt;&lt;TD&gt;&lt;verbatim&gt;$v&lt;/verbatim&gt;&lt;/TD&gt;&quot;
    }
    my puts &quot;&lt;/TABLE&gt;&lt;p&gt;&quot;
    my puts &quot;Send some info:&lt;p&gt;&quot;
    my puts &quot;&lt;FORM action=/[my request get REQUEST_PATH] method POST&gt;&quot;
    my puts &quot;&lt;TABLE&gt;&quot;
    foreach field {name rank serial_number} {
      set line &quot;&lt;TR&gt;&lt;TH&gt;$field&lt;/TH&gt;&lt;TD&gt;&lt;input name=\&quot;$field\&quot; &quot;
      if {[dict exists $form $field]} {
        append line &quot; value=\&quot;[dict get $form $field]\&quot;&quot;&quot;
      }
      append line &quot; /&gt;&lt;/TD&gt;&lt;/TR&gt;&quot;

Added examples/httpd/htdocs/html_static_page.html. 













>
>
>
>
>

1
2
3
4
5

<html><header><title>Static Content</title></header>
<body>
<h1>Static Content</h1>
This page is static content embedded in the file system. Nothing fancy.
</body></html>

Changes to examples/httpd/htdocs/index.md. 

1
2
3
4
5
6

7
8
9
10
11
12
13

Your test server works!

* [Tcllib embedded docs](/tcllib/index.html)
* [Tcllib's fossil repo (hosted via SCGI)](/fossil)
* [Standard Markdown Example Page](example.md)
* [Static HTML Page](html_static_page.html)


A locally served image:
![Locally Served Image](/tcllib/image/arch_core_container.png "Core Container")

Internal documentation for httpd:

* [Operating Principals](operations.md)







>








1
2
3
4
5
6
7
8
9
10
11
12
13
14

Your test server works!

* [Tcllib embedded docs](/tcllib/index.html)
* [Tcllib's fossil repo (hosted via SCGI)](/fossil)
* [Standard Markdown Example Page](example.md)
* [Static HTML Page](html_static_page.html)
* [Template HTML Page](header.tml)

A locally served image:
![Locally Served Image](/tcllib/image/arch_core_container.png "Core Container")

Internal documentation for httpd:

* [Operating Principals](operations.md)

Changes to examples/httpd/httpd.tcl. 

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
..
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
...
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
...
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193



clay::define httpd::content.fossil_node_proxy {

  superclass httpd::content.proxy

  method FileName {} {
    set uri    [my clay get REQUEST_URI]
    set prefix [my clay get prefix]
    set module [lindex [split $uri /] 2]
    if {![info exists ::fossil_process($module)]} {
      set dbfiles [::fossil-list]
      foreach file [lsort -dictionary $dbfiles]  {
        dict set result [file rootname [file tail $file]] $file
      }
................................................................................
      }
      set ::fossil_process($module) $dbfile
    }
    return [list $module $::fossil_process($module)]
  }

  method proxy_path {} {
    set uri [string trimleft [my clay get REQUEST_URI] /]
    set prefix [my clay get prefix]
    set module [lindex [split $uri /] 1]
    set path /[string range $uri [string length $prefix/$module] end]
    return $path
  }

  method proxy_channel {} {
    ###
    # This method returns a channel to the
    # proxied socket/stdout/etc
    ###
    lassign [my FileName] module dbfile
    set EXE [my Cgi_Executable fossil]
    set baseurl http://[my clay get HTTP_HOST][my clay get prefix]/$module
    if { $::tcl_platform(platform) eq "windows"} {
      return [open "|fossil.exe http $dbfile -baseurl $baseurl" r+]
    } else {
      return [open "|fossil http $dbfile -baseurl $baseurl 2>@1" r+]
    }
  }
}

clay::define httpd::content.fossil_node_scgi {

  superclass httpd::content.scgi
  method scgi_info {} {
    set uri    [my clay get REQUEST_URI]
    set prefix [my clay get prefix]
    set module [lindex [split $uri /] 2]
    file mkdir ~/tmp
    if {![info exists ::fossil_process($module)]} {
      package require processman
      package require nettool
      set port [::nettool::allocate_port 40000]
................................................................................
    foreach {f v} [my request dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach {f v} [my clay dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><th>File Size</th><td>[my clay get CONTENT_LENGTH]</td></tr>"
    my puts </TABLE>
    my puts </BODY></HTML>
  }

}

::clay::define ::docserver::upload {
................................................................................
    foreach part [dict getnull $FORMDAT MIME_PARTS] {
      my puts "<tr><td colspan=10><hr></td></tr>"
      foreach f [::mime::getheader $part -names] {
        my puts "<tr><th>$f</th><td>[mime::getheader $part $f]</td></tr>"
      }
      my puts "<tr><td colspan=10>[::mime::getbody $part -decode]</td></tr>"
    }
    my puts "<tr><th>File Size</th><td>[my clay get CONTENT_LENGTH]</td></tr>"
    my puts </TABLE>
    my puts </BODY></HTML>
  }
}
set serveropts [::httpd::server clay get server/]
foreach {f v}  [::clay::args_to_options {*}$::argv] {
  if {[dict exists $serveropts $f]} {








|







 







|













|












|







 







|







 







|








46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
..
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
...
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
...
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193



clay::define httpd::content.fossil_node_proxy {

  superclass httpd::content.proxy

  method FileName {} {
    set uri    [my request get REQUEST_URI]
    set prefix [my clay get prefix]
    set module [lindex [split $uri /] 2]
    if {![info exists ::fossil_process($module)]} {
      set dbfiles [::fossil-list]
      foreach file [lsort -dictionary $dbfiles]  {
        dict set result [file rootname [file tail $file]] $file
      }
................................................................................
      }
      set ::fossil_process($module) $dbfile
    }
    return [list $module $::fossil_process($module)]
  }

  method proxy_path {} {
    set uri [string trimleft [my request get REQUEST_URI] /]
    set prefix [my clay get prefix]
    set module [lindex [split $uri /] 1]
    set path /[string range $uri [string length $prefix/$module] end]
    return $path
  }

  method proxy_channel {} {
    ###
    # This method returns a channel to the
    # proxied socket/stdout/etc
    ###
    lassign [my FileName] module dbfile
    set EXE [my Cgi_Executable fossil]
    set baseurl http://[my request get HTTP_HOST][my clay get prefix]/$module
    if { $::tcl_platform(platform) eq "windows"} {
      return [open "|fossil.exe http $dbfile -baseurl $baseurl" r+]
    } else {
      return [open "|fossil http $dbfile -baseurl $baseurl 2>@1" r+]
    }
  }
}

clay::define httpd::content.fossil_node_scgi {

  superclass httpd::content.scgi
  method scgi_info {} {
    set uri    [my request get REQUEST_URI]
    set prefix [my clay get prefix]
    set module [lindex [split $uri /] 2]
    file mkdir ~/tmp
    if {![info exists ::fossil_process($module)]} {
      package require processman
      package require nettool
      set port [::nettool::allocate_port 40000]
................................................................................
    foreach {f v} [my request dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><td colspan=10><hr></td></tr>"
    foreach {f v} [my clay dump] {
        my puts "<tr><th>$f</th><td>$v</td></tr>"
    }
    my puts "<tr><th>File Size</th><td>[my request get CONTENT_LENGTH]</td></tr>"
    my puts </TABLE>
    my puts </BODY></HTML>
  }

}

::clay::define ::docserver::upload {
................................................................................
    foreach part [dict getnull $FORMDAT MIME_PARTS] {
      my puts "<tr><td colspan=10><hr></td></tr>"
      foreach f [::mime::getheader $part -names] {
        my puts "<tr><th>$f</th><td>[mime::getheader $part $f]</td></tr>"
      }
      my puts "<tr><td colspan=10>[::mime::getbody $part -decode]</td></tr>"
    }
    my puts "<tr><th>File Size</th><td>[my request get CONTENT_LENGTH]</td></tr>"
    my puts </TABLE>
    my puts </BODY></HTML>
  }
}
set serveropts [::httpd::server clay get server/]
foreach {f v}  [::clay::args_to_options {*}$::argv] {
  if {[dict exists $serveropts $f]} {

Changes to idoc/man/files/modules/httpd/httpd.n. 

608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
...
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655

tool::define ::test::content\&.file {
	superclass ::httpd::content\&.file
	# Return a file
	# Note: this is using the content\&.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my http_info get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index\&.html]
	}
}
tool::define ::test::content\&.time {
  # return the current system time
	method content {} {
................................................................................
    my puts "You Sent<p>"
    my puts "<TABLE>"
    foreach {f v} $form {
      my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
    }
    my puts "</TABLE><p>"
    my puts "Send some info:<p>"
    my puts "<FORM action=/[my http_info get REQUEST_PATH] method POST>"
    my puts "<TABLE>"
    foreach field {name rank serial_number} {
      set line "<TR><TH>$field</TH><TD><input name=\\"$field\\" "
      if {[dict exists $form $field]} {
        append line " value=\\"[dict get $form $field]\\"""
      }
      append line " /></TD></TR>"








|







 







|








608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
...
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655

tool::define ::test::content\&.file {
	superclass ::httpd::content\&.file
	# Return a file
	# Note: this is using the content\&.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my clay get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index\&.html]
	}
}
tool::define ::test::content\&.time {
  # return the current system time
	method content {} {
................................................................................
    my puts "You Sent<p>"
    my puts "<TABLE>"
    foreach {f v} $form {
      my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
    }
    my puts "</TABLE><p>"
    my puts "Send some info:<p>"
    my puts "<FORM action=/[my request get REQUEST_PATH] method POST>"
    my puts "<TABLE>"
    foreach field {name rank serial_number} {
      set line "<TR><TH>$field</TH><TD><input name=\\"$field\\" "
      if {[dict exists $form $field]} {
        append line " value=\\"[dict get $form $field]\\"""
      }
      append line " /></TD></TR>"

Changes to idoc/www/tcllib/files/modules/httpd/httpd.html. 

389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
...
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436

tool::define ::test::content.file {
	superclass ::httpd::content.file
	# Return a file
	# Note: this is using the content.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my http_info get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index.html]
	}
}
tool::define ::test::content.time {
  # return the current system time
	method content {} {
................................................................................
    my puts &quot;You Sent&lt;p&gt;&quot;
    my puts &quot;&lt;TABLE&gt;&quot;
    foreach {f v} $form {
      my puts &quot;&lt;TR&gt;&lt;TH&gt;$f&lt;/TH&gt;&lt;TD&gt;&lt;verbatim&gt;$v&lt;/verbatim&gt;&lt;/TD&gt;&quot;
    }
    my puts &quot;&lt;/TABLE&gt;&lt;p&gt;&quot;
    my puts &quot;Send some info:&lt;p&gt;&quot;
    my puts &quot;&lt;FORM action=/[my http_info get REQUEST_PATH] method POST&gt;&quot;
    my puts &quot;&lt;TABLE&gt;&quot;
    foreach field {name rank serial_number} {
      set line &quot;&lt;TR&gt;&lt;TH&gt;$field&lt;/TH&gt;&lt;TD&gt;&lt;input name=\&quot;$field\&quot; &quot;
      if {[dict exists $form $field]} {
        append line &quot; value=\&quot;[dict get $form $field]\&quot;&quot;&quot;
      }
      append line &quot; /&gt;&lt;/TD&gt;&lt;/TR&gt;&quot;








|







 







|








389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
...
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436

tool::define ::test::content.file {
	superclass ::httpd::content.file
	# Return a file
	# Note: this is using the content.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my clay get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index.html]
	}
}
tool::define ::test::content.time {
  # return the current system time
	method content {} {
................................................................................
    my puts &quot;You Sent&lt;p&gt;&quot;
    my puts &quot;&lt;TABLE&gt;&quot;
    foreach {f v} $form {
      my puts &quot;&lt;TR&gt;&lt;TH&gt;$f&lt;/TH&gt;&lt;TD&gt;&lt;verbatim&gt;$v&lt;/verbatim&gt;&lt;/TD&gt;&quot;
    }
    my puts &quot;&lt;/TABLE&gt;&lt;p&gt;&quot;
    my puts &quot;Send some info:&lt;p&gt;&quot;
    my puts &quot;&lt;FORM action=/[my request get REQUEST_PATH] method POST&gt;&quot;
    my puts &quot;&lt;TABLE&gt;&quot;
    foreach field {name rank serial_number} {
      set line &quot;&lt;TR&gt;&lt;TH&gt;$field&lt;/TH&gt;&lt;TD&gt;&lt;input name=\&quot;$field\&quot; &quot;
      if {[dict exists $form $field]} {
        append line &quot; value=\&quot;[dict get $form $field]\&quot;&quot;&quot;
      }
      append line &quot; /&gt;&lt;/TD&gt;&lt;/TR&gt;&quot;

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

1
2
3
4
5
6
7
8
9
10
11
..
95
96
97
98
99
100
101







102
103
104
105
106
107

108
109
110
111
112
113

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

set version 0.2
set module clay

set fout [open [file join $moddir ${module}.tcl] w]
dict set map %module% $module
dict set map %version% $version

puts $fout [string map $map {
................................................................................
# full path name of this file's directory.

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








close $fout

###
# Generate the test script
###

source [file join $srcdir procs.tcl]
set fout [open [file join $moddir $module.test] w]
puts $fout [source [file join $srcdir test.tcl]]
close $fout






|







 







>
>
>
>
>
>
>






>







1
2
3
4
5
6
7
8
9
10
11
..
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

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

set version 0.3
set module clay

set fout [open [file join $moddir ${module}.tcl] w]
dict set map %module% $module
dict set map %version% $version

puts $fout [string map $map {
................................................................................
# full path name of this file's directory.

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

#package ifneeded oo::meta 0.8 {package require %module% %version ; package provide oo::meta 0.8}
#package ifneeded oo::option 0.4 {package require %module% %version ; package provide oo::option 0.4}

puts $fout [string map $map {
package ifneeded oo::meta 0.8 [list source [file join $dir %module%.tcl]]
}]

close $fout

###
# Generate the test script
###
namespace eval ::clay {}
source [file join $srcdir procs.tcl]
set fout [open [file join $moddir $module.test] w]
puts $fout [source [file join $srcdir test.tcl]]
close $fout

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

16
17
18
19
20
21
22
23













24
25










26


27
28
29
30
31
32
33
34
35
36

        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 {








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

<








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

        return [dict exists $clay {*}$path]
      }
      dump {
        return $clay
      }
      getnull -
      get {
        set path $args
        set leaf [expr {[string index [lindex $path end] end] ne "/"}]
        set clayorder [::clay::ancestors [self]]
        #puts [list [self] clay get {*}$path (leaf: $leaf)]
        if {$leaf} {
          #puts [list EXISTS: (clay) [dict exists $clay {*}$path]]
          if {[dict exists $clay {*}$path]} {
            return [dict get $clay {*}$path]
          }
          #puts [list Search in the in our list of classes for an answer]
          foreach class $clayorder {
            if {$class eq [self]} continue
            if {[$class clay exists {*}$path]} {
              set value [$class clay get {*}$path]
              return $value
            }
          }
        } else {
          set result {}
          # Leaf searches return one data field at a time
          # Search in our local dict
          # Search in the in our list of classes for an answer
          foreach class [lreverse $clayorder] {
            if {$class eq [self]} continue
            ::clay::dictmerge result [$class clay get {*}$path]
          }
          if {[dict exists $clay {*}$path]} {
            ::clay::dictmerge result [dict get $clay {*}$path]
          }
          return $result
        }

      }
      merge {
        foreach arg $args {
          ::clay::dictmerge clay {*}$arg
        }
      }
      search {

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

58
59
60
61
62
63
64
65
66
67

68
69
70
71
72
73
74

  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








|
|
<
>








58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
74

  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

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

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
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
...
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142

143
144
145
146
147
148
149
...
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

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

###
................................................................................
  ::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:
................................................................................
#    [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]
  }
}
................................................................................
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  Variable clay {}
  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]}








<
|
|
|
|
|
|
|
|
<










|


|







 







|







 







|


|







 







|




|
|
<
>







 







|
|
<
<
<

<
<





<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








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
..
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
...
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
...
126
127
128
129
130
131
132
133
134
135
136
137
138
139

140
141
142
143
144
145
146
147
...
159
160
161
162
163
164
165
166
167



168


169
170
171
172
173



174
































175
176
177
178
179
180
181

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

proc ::clay::dynamic_methods_class {thisclass} {
  set methods {}

  set mdata [$thisclass 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 array/ $name {}
  }
  foreach {var val} $values {
    $class clay set array/ $name $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::clay::define::component {name info} {
................................................................................
###
proc ::clay::define::constructor {arglist rawbody} {
  set body {
my variable DestroyEvent
set DestroyEvent 0
::clay::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###
................................................................................
  ::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 dict/ $name {}
  }
  foreach {var val} $values {
    $class clay set dict/ $name $var $val
  }
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
................................................................................
#    [para]
#    Variables registered in the variable property are also initialized
#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::clay::define::Variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :/]
  $class clay set variable/ $name $default
  #::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]
  }
}
................................................................................
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  Variable clay {}
  Variable claycache {}
  Variable DestroyEvent 0

  method InitializePublic {} {
    next



    my variable clayorder clay claycache


    if {[info exists clay]} {
      set emap [dict getnull $clay method_ensemble/]
    } else {
      set emap {}
    }



    foreach class [lreverse $clayorder] {
































      ###
      # Build a compsite map of all ensembles defined by the object's current
      # class as well as all of the classes being mixed in
      ###
      foreach {mensemble einfo} [$class clay get method_ensemble/] {
        set ensemble [string trim $mensemble :/]
        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}

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

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
..
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
..
83
84
85
86
87
88
89

90
91
92
93
94
95
96
...
122
123
124
125
126
127
128
129
130

131
132
133
134
135
136
137
...
178
179
180
181
182
183
184
185
186
187
188
189
190
191



192
193
194
195
196
197
198
...
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
...
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
...
296
297
298
299
300
301
302

303
304
305
306
307
308
309
310
311
312
313
314





315







316


































































  # 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]]]
    }
    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]
        }
................................................................................
            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 {
        if {![dict exists $clay delegate/ <class>]} {
          dict set clay delegate/ <class> [info object class [self]]
        }
................................................................................
      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]} {
................................................................................
          } 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
        }
................................................................................
              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]} {
................................................................................
        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]"
              }
            }
          }
        }
................................................................................
              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
            }
            break
          }
        }
      }
      mixinmap {




        if {[llength $args]==0} {
          return [my clay get mixin/]

        } elseif {[llength $args]==1} {
          return [my clay get mixin/ [lindex $args 0]]

        } else {
          foreach {slot classes} $args {
            dict set clay mixin/ $slot $classes
          }
          set claycache {}
          set classlist {}
          foreach {item class} [my clay get mixin/] {
            if {$class ne {}} {
              lappend classlist $class
            }
          }
          my clay mixin {*}$classlist
        }
      }
................................................................................
        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 {} {}





}

















































































|


>










>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<
<
<







 







>







 







|
|
>







 







<
<
|

|


>
>
>







 







|












|


|







 







>
>
>
>

<
>

<
>


|



|







 







>











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

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
..
47
48
49
50
51
52
53








54
55
56
57
58
59
60
..
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
...
182
183
184
185
186
187
188


189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
...
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
...
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
...
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

  # 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 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
      }
      cget {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[llength $args]==1} {
          set field [string trim [lindex $args 0] -:/]
          if {[info exists option_canonical($field)]} {
            set field $option_canonical($field)
          }
          if {[dict exists $config $field]} {
            return [dict get $config $field]
          }
        }
        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]
        }
................................................................................
            return $value
          }
          if {[$class clay exists const/ {*}$args]} {
            set value [$class clay get const/ {*}$args]
            dict set claycache {*}$args $value
            return $value
          }








        }
        return {}
      }
      delegate {
        if {![dict exists $clay delegate/ <class>]} {
          dict set clay delegate/ <class> [info object class [self]]
        }
................................................................................
      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]
        }
        ::clay::dictmerge result $clay
        return $result
      }
      ensemble_map {
        set ensemble [lindex $args 0]
        my variable claycache
        set mensemble [string trim $ensemble :/]/
        if {[dict exists $claycache method_ensemble/ $mensemble]} {
................................................................................
          } elseif {
            append buffer "my $thisline" \n
          }
          set thisline {}
        }
        eval $buffer
      }
      evolve -
      initialize {
        my InitializePublic
      }
      exists {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[dict exists $clay {*}$args]} {
          return 1
        }
................................................................................
              return $value
            }
          }
        } else {
          set result {}
          # Leaf searches return one data field at a time
          # Search in our local dict



          # Search in the in our list of classes for an answer
          foreach class [lreverse $clayorder] {
            ::clay::dictmerge result [$class clay get {*}$args]
          }
          if {[dict exists $clay {*}$args]} {
            ::clay::dictmerge result [dict get $clay {*}$args]
          }
          return $result
        }
      }
      leaf {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[dict exists $clay {*}$args]} {
................................................................................
        set newmixin {}
        foreach item $args {
          lappend newmixin ::[string trimleft $item :]
        }
        set newmap $args
        foreach class $prior {
          if {$class ni $newmixin} {
            set script [$class clay get mixin/ unmap-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
        ::oo::objdefine [self] mixin {*}$args
        ###
        # Build a compsite map of all ensembles defined by the object's current
        # class as well as all of the classes being mixed in
        ###
        my InitializePublic
        foreach class $newmixin {
          if {$class ni $prior} {
            set script [$class clay get mixin/ map-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
................................................................................
              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
            }
            break
          }
        }
      }
      mixinmap {
        my variable clay
        if {![dict exists $clay mixin]} {
          dict set clay mixin {}
        }
        if {[llength $args]==0} {

          return [dict get $clay mixin]
        } elseif {[llength $args]==1} {

          return [dict getnull $clay mixin [lindex $args 0]]
        } else {
          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 {*}$classlist
        }
      }
................................................................................
        set clay [lindex $args 0]
      }
      source {
        source [lindex $args 0]
      }
      set {
        #puts [list [self] clay SET {*}$args]
        set claycache {}
        ::clay::dictmerge clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
    }
  }

  ###
  # React to a 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 config]} {
      set config {}
    }
    foreach {var value} [my clay get 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} [my clay get 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} [my clay get dict/] {
      set var [string trim $var :/]
      foreach {f v} [my clay get $var/] {
        if {![dict exists ${var} $f]} {
          if {$::clay::trace>2} {puts [list initialize dict (from const) $var $f $v]}
          dict set ${var} $f $v
        }
      }
    }
    foreach {var value} [my clay get 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
        }
      }
    }
    foreach {var value} [my clay get array/] {
      set var [string trim $var :/]
      foreach {f v} [my clay get $var/] {
        if {![array exists ${var}($f)]} {
          if {$::clay::trace>2} {puts [list initialize array (from const) $var\($f\) $v]}
          set ${var}($f) $v
        }
      }
    }
    foreach {field info} [my clay get option/] {
      set field [string trim $field -/:]
      foreach alias [dict getnull $info aliases] {
        set option_canonical($alias) $field
      }
      if {[dict exists $config $field]} continue
      set getcmd [dict getnull $info default-command]
      if {$getcmd ne {}} {
        set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        set value [dict getnull $info default]
      }
      dict set config $field $value
      set setcmd [dict getnull $info set-command]
      if {$setcmd ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
      }
    }
  }
}

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

1
2
3
4
5
6
7
8
...
322
323
324
325
326
327
328

329
330

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

###
# Global utilities
###
if {[info commands ::ladd] eq {}} {
  proc ladd {varname args} {
................................................................................
}

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

namespace eval ::clay {

  variable core_classes {::oo::class ::oo::object}
}

|







 







>



1
2
3
4
5
6
7
8
...
322
323
324
325
326
327
328
329
330
331


set ::clay::trace 0

###
# Global utilities
###
if {[info commands ::ladd] eq {}} {
  proc ladd {varname args} {
................................................................................
}

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

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

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

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
...
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
...
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
...
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
...
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
....
1052
1053
1054
1055
1056
1057
1058











































































































































































































































1059
1060
1061
1062
1063
1064
1065

} {color yellow flavor strawberry}

::clay::dictmerge foo bar/ baz/ bang/ {color blue}
test dictmerge-0007 {Branches are merged}  {
  dict get $foo bar/ baz/ bang/
} {color blue flavor strawberry}

::clay::dictmerge foo {public/ {option/ {color {type color} flavor {sense taste}}}}
::clay::dictmerge foo {public/ {option/ {format {default ascii}}}}

test dictmerge-0008 {Whole dicts are merged}  {
  dict get $foo public/ option/ color
} {type color}
test dictmerge-0009 {Whole dicts are merged}  {
  dict get $foo public/ option/ flavor
} {sense taste}
test dictmerge-0010 {Whole dicts are merged}  {
  dict get $foo public/ option/ format
} {default ascii}


































}

putb result {
# -------------------------------------------------------------------------

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

................................................................................
# Test clay information is passed town to subclasses
###
test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclasse clay get color
} blue
test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} {
  ::TEST::myclasse clay get flavor
} {}


###
# Test that properties reach objects
###
set OBJ3 [::TEST::myclasse new {}]
test clay-object-clay-b-0001 {Test that objects of the class get properties} {
................................................................................
    my variable my_variable
    return $my_variable
  }
}

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

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

###
................................................................................
    my variable my_array
    return $my_array($field)
  }
}

set OBJ [::TEST::has_array new]
test clay-class-array-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get public/ array/
} {my_array/ {timeout 10}}

test clay-class-arrau-0002 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_array timeout
} 10

###
................................................................................
    my variable my_dict
    return [dict get $my_dict {*}$args]
  }
}

set OBJ [::TEST::has_dict new]
test clay-class-dict-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get public/ dict/
} {my_dict/ {timeout 10}}

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

###
................................................................................
    set map [dict create %object% $object %action% $action %value% $value]
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {test clay-dynamic-ensemble-%testnum% {Test ensemble with static method} {
  $%object% myensemble %action%
} {%value%}}
  }
}












































































































































































































































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

putb result {








|
|


|


|


|

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







 







|







 







|







 







|







 







|







 







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








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
...
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
...
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
...
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
...
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
....
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
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334

} {color yellow flavor strawberry}

::clay::dictmerge foo bar/ baz/ bang/ {color blue}
test dictmerge-0007 {Branches are merged}  {
  dict get $foo bar/ baz/ bang/
} {color blue flavor strawberry}

::clay::dictmerge foo {option/ {color {type color} flavor {sense taste}}}
::clay::dictmerge foo {option/ {format {default ascii}}}

test dictmerge-0008 {Whole dicts are merged}  {
  dict get $foo option/ color
} {type color}
test dictmerge-0009 {Whole dicts are merged}  {
  dict get $foo option/ flavor
} {sense taste}
test dictmerge-0010 {Whole dicts are merged}  {
  dict get $foo option/ format
} {default ascii}

###
# Tests for the httpd module
###
test dictmerge-0010 {Test that leaves are merged properly}
set bar {}
::clay::dictmerge bar {
   proxy/ {port 10101 host myhost.localhost}
}
::clay::dictmerge bar {
   mimetxt {Host: localhost
Content_Type: text/plain
Content-Length: 15
}
   http {HTTP_HOST {} CONTENT_LENGTH 15 HOST localhost CONTENT_TYPE text/plain UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e REMOTE_ADDR 127.0.0.1 REMOTE_HOST 127.0.0.1 REQUEST_METHOD POST REQUEST_URI /echo REQUEST_PATH echo REQUEST_VERSION 1.0 DOCUMENT_ROOT {} QUERY_STRING {} REQUEST_RAW {POST /echo HTTP/1.0} SERVER_PORT 10001 SERVER_NAME 127.0.0.1 SERVER_PROTOCOL HTTP/1.1 SERVER_SOFTWARE {TclHttpd 4.2.0} LOCALHOST 0} UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e uriinfo {fragment {} port {} path echo scheme http host {} query {} pbare 0 pwd {} user {}}
   mixin {reply ::test::content.echo}
   prefix /echo
   proxy_port 10010
   proxy/ {host localhost}
}

test dictmerge-0011 {Whole dicts are merged}  {
  dict get $bar proxy_port
} {10010}

test dictmerge-0012 {Whole dicts are merged}  {
  dict get $bar http CONTENT_LENGTH
} 15
test dictmerge-0013 {Whole dicts are merged}  {
  dict get $bar proxy/ host
} localhost
test dictmerge-0014 {Whole dicts are merged}  {
  dict get $bar proxy/ port
} 10101
}

putb result {
# -------------------------------------------------------------------------

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

................................................................................
# Test clay information is passed town to subclasses
###
test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclasse clay get color
} blue
test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} {
  ::TEST::myclasse clay get flavor
} {strawberry}


###
# Test that properties reach objects
###
set OBJ3 [::TEST::myclasse new {}]
test clay-object-clay-b-0001 {Test that objects of the class get properties} {
................................................................................
    my variable my_variable
    return $my_variable
  }
}

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

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

###
................................................................................
    my variable my_array
    return $my_array($field)
  }
}

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

test clay-class-arrau-0002 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_array timeout
} 10

###
................................................................................
    my variable my_dict
    return [dict get $my_dict {*}$args]
  }
}

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

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

###
................................................................................
    set map [dict create %object% $object %action% $action %value% $value]
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {test clay-dynamic-ensemble-%testnum% {Test ensemble with static method} {
  $%object% myensemble %action%
} {%value%}}
  }
}

putb result {

###
# Class method testing
###

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

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

  constructor {TkPath args} {
    my variable hull
    set hull $TkPath
    my clay delegate hull $TkPath
  }

  method tkalias tkname {
    set oldname $tkname
    my variable tkalias
    set tkalias $tkname
    set self [self]
    set hullwidget [::info object namespace $self]::tkwidget
    my clay delegate tkwidget $hullwidget
    #rename ::$tkalias $hullwidget
    my clay delegate hullwidget $hullwidget
    #::tool::object_rename [self] ::$tkalias
    rename [self] ::$tkalias
    #my Hull_Bind $tkname
    return $hullwidget
  }
}

test tool-class-method-000 {Test that class methods actually work...} {
  WidgetClass working
} {Works}

test tool-class-method-001 {Test Tk style creator} {
  WidgetClass .foo
  .foo clay delegate hull
} {.foo}

::clay::define WidgetNewClass {
  superclass WidgetClass
}

test tool-class-method-002 {Test Tk style creator inherited by morph} {
  WidgetNewClass .bar
  .bar clay delegate hull
} {.bar}



###
# Test ensemble inheritence
###
clay::define NestedClassA {
  Ensemble do::family {} {
    return NestedClassA
  }
  Ensemble do::something {} {
    return A
  }
  Ensemble do::whop {} {
    return A
  }
}
clay::define NestedClassB {
  superclass NestedClassA
  Ensemble do::family {} {
    set r [next family]
    lappend r NestedClassB
    return $r
  }
  Ensemble do::whop {} {
    return B
  }
}
clay::define NestedClassC {
  superclass NestedClassB

  Ensemble do::somethingelse {} {
    return C
  }
}
clay::define NestedClassD {
  superclass NestedClassB

  Ensemble do::somethingelse {} {
    return D
  }
}

clay::define NestedClassE {
  superclass NestedClassD NestedClassC
}

clay::define NestedClassF {
  superclass NestedClassC NestedClassD
}

NestedClassC create NestedObjectC

###
# These tests no longer work because method ensembles are now dynamically
# generated by object, that are not attached to the class anymore
#
####
#test tool-ensemble-001 {Test that an ensemble can access [next] even if no object of the ancestor class have been instantiated} {
#  NestedObjectC do family
#} {::NestedClassA ::NestedClassB ::NestedClassC}

test tool-ensemble-002 {Test that a later ensemble definition trumps a more primitive one} {
  NestedObjectC do whop
} {B}
test tool-ensemble-003 {Test that an ensemble definitions in an ancestor carry over} {
  NestedObjectC do something
} {A}

NestedClassE create NestedObjectE
NestedClassF create NestedObjectF


test tool-ensemble-004 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectE do somethingelse
} {D}

test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectF do somethingelse
} {C}

###
# Set of tests to exercise the mixinmap system
###
clay::define MixinMainClass {
  Variable mainvar unchanged

  Ensemble test::which {} {
    my variable mainvar
    return $mainvar
  }

  Ensemble test::main args {
    puts [list this is main $method $args]
  }

}

set mixoutscript {my test untool $class}
set mixinscript {my test tool $class}
clay::define MixinTool {
  Variable toolvar unchanged.mixin
  clay set mixin/ unmap-script $mixoutscript
  clay set mixin/ map-script $mixinscript
  clay set mixin/ name {Generic Tool}

  Ensemble test::untool class {
    my variable toolvar mainvar
    set mainvar {}
    set toolvar {}
  }

  Ensemble test::tool class {
    my variable toolvar mainvar
    set mainvar [$class clay get mixin/ name]
    set toolvar [$class clay get mixin/ name]
  }
}

clay::define MixinToolA {
  superclass MixinTool

  clay set mixin/ name {Tool A}
}

clay::define MixinToolB {
  superclass MixinTool

  clay set mixin/ name {Tool B}

  method test_newfunc {} {
    return "B"
  }
}

test tool-mixinspec-001 {Test application of mixin specs} {
  MixinTool clay get mixin/ map-script
} $mixinscript

test tool-mixinspec-002 {Test application of mixin specs} {
  MixinToolA clay get mixin/ map-script
} $mixinscript

test tool-mixinspec-003 {Test application of mixin specs} {
  MixinToolB clay get mixin/ map-script
} $mixinscript


MixinMainClass create mixintest

test tool-mixinmap-001 {Test object prior to mixins} {
  mixintest test which
} {unchanged}

mixintest clay mixinmap tool MixinToolA
test tool-mixinmap-002 {Test mixin map script ran} {
  mixintest test which
} {Tool A}

mixintest clay mixinmap tool MixinToolB

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test which
} {Tool B}

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test_newfunc
} {B}

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

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

putb result {

Changes to modules/clay/clay.tcl. 

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
..
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
..
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
...
372
373
374
375
376
377
378

379
380
381
382
383
384
385
...
403
404
405
406
407
408
409
410













411
412










413


414
415
416
417
418
419
420
421
422
423
...
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
...
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
...
531
532
533
534
535
536
537

538
539
540
541
542
543
544
...
570
571
572
573
574
575
576
577
578

579
580
581
582
583
584
585
...
626
627
628
629
630
631
632
633
634
635
636
637
638
639



640
641
642
643
644
645
646
...
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
...
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
...
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
...
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
...
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
...
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
...
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913

914
915
916
917
918
919
920
...
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
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
....
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089

1090
1091
1092
1093
1094
1095
1096

# clay.tcl
#
# Copyright (c) 2018 Sean Woods
#
# BSD License
###
# @@ Meta Begin
# Package clay 0.2
# 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 End

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

###
# START: core.tcl
###
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require TclOO
................................................................................

###
# END: core.tcl
###
###
# START: procs.tcl
###
::namespace eval ::clay {}
set ::clay::trace 0

###
# Global utilities
###
if {[info commands ::ladd] eq {}} {
  proc ladd {varname args} {
................................................................................
}

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

namespace eval ::clay {

  variable core_classes {::oo::class ::oo::object}
}

###
# END: procs.tcl
###
###
................................................................................
        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 {
................................................................................
  # 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]]]
    }
    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]
        }
................................................................................
            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 {
        if {![dict exists $clay delegate/ <class>]} {
          dict set clay delegate/ <class> [info object class [self]]
        }
................................................................................
      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]} {
................................................................................
          } 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
        }
................................................................................
              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]} {
................................................................................
        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]"
              }
            }
          }
        }
................................................................................
              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
            }
            break
          }
        }
      }
      mixinmap {




        if {[llength $args]==0} {
          return [my clay get mixin/]

        } elseif {[llength $args]==1} {
          return [my clay get mixin/ [lindex $args 0]]

        } else {
          foreach {slot classes} $args {
            dict set clay mixin/ $slot $classes
          }
          set claycache {}
          set classlist {}
          foreach {item class} [my clay get mixin/] {
            if {$class ne {}} {
              lappend classlist $class
            }
          }
          my clay mixin {*}$classlist
        }
      }
................................................................................
        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
###
###
................................................................................
  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} {
................................................................................
###
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
}

###
................................................................................
  ::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:
................................................................................
#    [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]
  }
}
................................................................................
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  Variable clay {}
  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]}
................................................................................
  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








|







 







|







 







|







 







>







 







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

<







 







|


>










>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<
<
<







 







>







 







|
|
>







 







<
<
|

|


>
>
>







 







|












|


|







 







>
>
>
>

<
>

<
>


|



|







 







>











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







 







<
|
|
|
|
|
|
|
|
<










|


|







 







|







 







|


|







 







|




|
|
<
>







 







|
|
<
<
<

<
<





<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|
|
<
>








3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
..
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
..
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
...
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
...
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
...
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
...
520
521
522
523
524
525
526








527
528
529
530
531
532
533
...
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
...
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
...
655
656
657
658
659
660
661


662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
...
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
...
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
...
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
...
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
...
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
...
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
....
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022

1023
1024
1025
1026
1027
1028
1029
1030
....
1042
1043
1044
1045
1046
1047
1048
1049
1050



1051


1052
1053
1054
1055
1056



1057
































1058
1059
1060
1061
1062
1063
1064
....
1150
1151
1152
1153
1154
1155
1156
1157
1158

1159
1160
1161
1162
1163
1164
1165
1166

# clay.tcl
#
# Copyright (c) 2018 Sean Woods
#
# BSD License
###
# @@ Meta Begin
# Package clay 0.3
# 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 End

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

###
# START: core.tcl
###
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require TclOO
................................................................................

###
# END: core.tcl
###
###
# START: procs.tcl
###

set ::clay::trace 0

###
# Global utilities
###
if {[info commands ::ladd] eq {}} {
  proc ladd {varname args} {
................................................................................
}

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

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

###
# END: procs.tcl
###
###
................................................................................
        return [dict exists $clay {*}$path]
      }
      dump {
        return $clay
      }
      getnull -
      get {
        set path $args
        set leaf [expr {[string index [lindex $path end] end] ne "/"}]
        set clayorder [::clay::ancestors [self]]
        #puts [list [self] clay get {*}$path (leaf: $leaf)]
        if {$leaf} {
          #puts [list EXISTS: (clay) [dict exists $clay {*}$path]]
          if {[dict exists $clay {*}$path]} {
            return [dict get $clay {*}$path]
          }
          #puts [list Search in the in our list of classes for an answer]
          foreach class $clayorder {
            if {$class eq [self]} continue
            if {[$class clay exists {*}$path]} {
              set value [$class clay get {*}$path]
              return $value
            }
          }
        } else {
          set result {}
          # Leaf searches return one data field at a time
          # Search in our local dict
          # Search in the in our list of classes for an answer
          foreach class [lreverse $clayorder] {
            if {$class eq [self]} continue
            ::clay::dictmerge result [$class clay get {*}$path]
          }
          if {[dict exists $clay {*}$path]} {
            ::clay::dictmerge result [dict get $clay {*}$path]
          }
          return $result
        }

      }
      merge {
        foreach arg $args {
          ::clay::dictmerge clay {*}$arg
        }
      }
      search {
................................................................................
  # 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 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
      }
      cget {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[llength $args]==1} {
          set field [string trim [lindex $args 0] -:/]
          if {[info exists option_canonical($field)]} {
            set field $option_canonical($field)
          }
          if {[dict exists $config $field]} {
            return [dict get $config $field]
          }
        }
        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]
        }
................................................................................
            return $value
          }
          if {[$class clay exists const/ {*}$args]} {
            set value [$class clay get const/ {*}$args]
            dict set claycache {*}$args $value
            return $value
          }








        }
        return {}
      }
      delegate {
        if {![dict exists $clay delegate/ <class>]} {
          dict set clay delegate/ <class> [info object class [self]]
        }
................................................................................
      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]
        }
        ::clay::dictmerge result $clay
        return $result
      }
      ensemble_map {
        set ensemble [lindex $args 0]
        my variable claycache
        set mensemble [string trim $ensemble :/]/
        if {[dict exists $claycache method_ensemble/ $mensemble]} {
................................................................................
          } elseif {
            append buffer "my $thisline" \n
          }
          set thisline {}
        }
        eval $buffer
      }
      evolve -
      initialize {
        my InitializePublic
      }
      exists {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[dict exists $clay {*}$args]} {
          return 1
        }
................................................................................
              return $value
            }
          }
        } else {
          set result {}
          # Leaf searches return one data field at a time
          # Search in our local dict



          # Search in the in our list of classes for an answer
          foreach class [lreverse $clayorder] {
            ::clay::dictmerge result [$class clay get {*}$args]
          }
          if {[dict exists $clay {*}$args]} {
            ::clay::dictmerge result [dict get $clay {*}$args]
          }
          return $result
        }
      }
      leaf {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[dict exists $clay {*}$args]} {
................................................................................
        set newmixin {}
        foreach item $args {
          lappend newmixin ::[string trimleft $item :]
        }
        set newmap $args
        foreach class $prior {
          if {$class ni $newmixin} {
            set script [$class clay get mixin/ unmap-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
        ::oo::objdefine [self] mixin {*}$args
        ###
        # Build a compsite map of all ensembles defined by the object's current
        # class as well as all of the classes being mixed in
        ###
        my InitializePublic
        foreach class $newmixin {
          if {$class ni $prior} {
            set script [$class clay get mixin/ map-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
................................................................................
              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
            }
            break
          }
        }
      }
      mixinmap {
        my variable clay
        if {![dict exists $clay mixin]} {
          dict set clay mixin {}
        }
        if {[llength $args]==0} {

          return [dict get $clay mixin]
        } elseif {[llength $args]==1} {

          return [dict getnull $clay mixin [lindex $args 0]]
        } else {
          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 {*}$classlist
        }
      }
................................................................................
        set clay [lindex $args 0]
      }
      source {
        source [lindex $args 0]
      }
      set {
        #puts [list [self] clay SET {*}$args]
        set claycache {}
        ::clay::dictmerge clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
    }
  }

  ###
  # React to a 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 config]} {
      set config {}
    }
    foreach {var value} [my clay get 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} [my clay get 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} [my clay get dict/] {
      set var [string trim $var :/]
      foreach {f v} [my clay get $var/] {
        if {![dict exists ${var} $f]} {
          if {$::clay::trace>2} {puts [list initialize dict (from const) $var $f $v]}
          dict set ${var} $f $v
        }
      }
    }
    foreach {var value} [my clay get 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
        }
      }
    }
    foreach {var value} [my clay get array/] {
      set var [string trim $var :/]
      foreach {f v} [my clay get $var/] {
        if {![array exists ${var}($f)]} {
          if {$::clay::trace>2} {puts [list initialize array (from const) $var\($f\) $v]}
          set ${var}($f) $v
        }
      }
    }
    foreach {field info} [my clay get option/] {
      set field [string trim $field -/:]
      foreach alias [dict getnull $info aliases] {
        set option_canonical($alias) $field
      }
      if {[dict exists $config $field]} continue
      set getcmd [dict getnull $info default-command]
      if {$getcmd ne {}} {
        set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        set value [dict getnull $info default]
      }
      dict set config $field $value
      set setcmd [dict getnull $info set-command]
      if {$setcmd ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
      }
    }
  }
}


###
# END: object.tcl
###
###
................................................................................
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class
  }
}

proc ::clay::dynamic_methods_class {thisclass} {
  set methods {}

  set mdata [$thisclass 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 array/ $name {}
  }
  foreach {var val} $values {
    $class clay set array/ $name $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::clay::define::component {name info} {
................................................................................
###
proc ::clay::define::constructor {arglist rawbody} {
  set body {
my variable DestroyEvent
set DestroyEvent 0
::clay::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###
................................................................................
  ::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 dict/ $name {}
  }
  foreach {var val} $values {
    $class clay set dict/ $name $var $val
  }
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
................................................................................
#    [para]
#    Variables registered in the variable property are also initialized
#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::clay::define::Variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :/]
  $class clay set variable/ $name $default
  #::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]
  }
}
................................................................................
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  Variable clay {}
  Variable claycache {}
  Variable DestroyEvent 0

  method InitializePublic {} {
    next



    my variable clayorder clay claycache


    if {[info exists clay]} {
      set emap [dict getnull $clay method_ensemble/]
    } else {
      set emap {}
    }



    foreach class [lreverse $clayorder] {
































      ###
      # Build a compsite map of all ensembles defined by the object's current
      # class as well as all of the classes being mixed in
      ###
      foreach {mensemble einfo} [$class clay get method_ensemble/] {
        set ensemble [string trim $mensemble :/]
        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}
................................................................................
  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

Changes to modules/clay/clay.test. 

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
...
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
....
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
....
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
....
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
....
1156
1157
1158
1159
1160
1161
1162
1163










































































































































































































































1164
1165
1166
1167
1168
1169
1170
1171

} {color yellow flavor strawberry}

::clay::dictmerge foo bar/ baz/ bang/ {color blue}
test dictmerge-0007 {Branches are merged}  {
  dict get $foo bar/ baz/ bang/
} {color blue flavor strawberry}

::clay::dictmerge foo {public/ {option/ {color {type color} flavor {sense taste}}}}
::clay::dictmerge foo {public/ {option/ {format {default ascii}}}}

test dictmerge-0008 {Whole dicts are merged}  {
  dict get $foo public/ option/ color
} {type color}
test dictmerge-0009 {Whole dicts are merged}  {
  dict get $foo public/ option/ flavor
} {sense taste}
test dictmerge-0010 {Whole dicts are merged}  {
  dict get $foo public/ option/ format
} {default ascii}




































# -------------------------------------------------------------------------

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

proc ::alpha::define::is_alpha {} {
  dict set ::testinfo([current_class]) is_alpha 1
................................................................................
# Test clay information is passed town to subclasses
###
test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclasse clay get color
} blue
test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} {
  ::TEST::myclasse clay get flavor
} {}


###
# Test that properties reach objects
###
set OBJ3 [::TEST::myclasse new {}]
test clay-object-clay-b-0001 {Test that objects of the class get properties} {
................................................................................
    my variable my_variable
    return $my_variable
  }
}

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

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

###
................................................................................
    my variable my_array
    return $my_array($field)
  }
}

set OBJ [::TEST::has_array new]
test clay-class-array-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get public/ array/
} {my_array/ {timeout 10}}

test clay-class-arrau-0002 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_array timeout
} 10

###
................................................................................
    my variable my_dict
    return [dict get $my_dict {*}$args]
  }
}

set OBJ [::TEST::has_dict new]
test clay-class-dict-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get public/ dict/
} {my_dict/ {timeout 10}}

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

###
................................................................................
# Test dance
test clay-dynamic-ensemble-0003 {Test ensemble with static method} {
  $OBJA myensemble dance
} {1}
test clay-dynamic-ensemble-0004 {Test ensemble with static method} {
  $OBJB myensemble dance
} {0}











































































































































































































































testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:










|
|


|


|


|


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







 







|







 







|







 







|







 







|







 








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









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
...
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
....
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
....
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
....
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
....
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
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
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439

} {color yellow flavor strawberry}

::clay::dictmerge foo bar/ baz/ bang/ {color blue}
test dictmerge-0007 {Branches are merged}  {
  dict get $foo bar/ baz/ bang/
} {color blue flavor strawberry}

::clay::dictmerge foo {option/ {color {type color} flavor {sense taste}}}
::clay::dictmerge foo {option/ {format {default ascii}}}

test dictmerge-0008 {Whole dicts are merged}  {
  dict get $foo option/ color
} {type color}
test dictmerge-0009 {Whole dicts are merged}  {
  dict get $foo option/ flavor
} {sense taste}
test dictmerge-0010 {Whole dicts are merged}  {
  dict get $foo option/ format
} {default ascii}

###
# Tests for the httpd module
###
test dictmerge-0010 {Test that leaves are merged properly}
set bar {}
::clay::dictmerge bar {
   proxy/ {port 10101 host myhost.localhost}
}
::clay::dictmerge bar {
   mimetxt {Host: localhost
Content_Type: text/plain
Content-Length: 15
}
   http {HTTP_HOST {} CONTENT_LENGTH 15 HOST localhost CONTENT_TYPE text/plain UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e REMOTE_ADDR 127.0.0.1 REMOTE_HOST 127.0.0.1 REQUEST_METHOD POST REQUEST_URI /echo REQUEST_PATH echo REQUEST_VERSION 1.0 DOCUMENT_ROOT {} QUERY_STRING {} REQUEST_RAW {POST /echo HTTP/1.0} SERVER_PORT 10001 SERVER_NAME 127.0.0.1 SERVER_PROTOCOL HTTP/1.1 SERVER_SOFTWARE {TclHttpd 4.2.0} LOCALHOST 0} UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e uriinfo {fragment {} port {} path echo scheme http host {} query {} pbare 0 pwd {} user {}}
   mixin {reply ::test::content.echo}
   prefix /echo
   proxy_port 10010
   proxy/ {host localhost}
}

test dictmerge-0011 {Whole dicts are merged}  {
  dict get $bar proxy_port
} {10010}

test dictmerge-0012 {Whole dicts are merged}  {
  dict get $bar http CONTENT_LENGTH
} 15
test dictmerge-0013 {Whole dicts are merged}  {
  dict get $bar proxy/ host
} localhost
test dictmerge-0014 {Whole dicts are merged}  {
  dict get $bar proxy/ port
} 10101


# -------------------------------------------------------------------------

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

proc ::alpha::define::is_alpha {} {
  dict set ::testinfo([current_class]) is_alpha 1
................................................................................
# Test clay information is passed town to subclasses
###
test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclasse clay get color
} blue
test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} {
  ::TEST::myclasse clay get flavor
} {strawberry}


###
# Test that properties reach objects
###
set OBJ3 [::TEST::myclasse new {}]
test clay-object-clay-b-0001 {Test that objects of the class get properties} {
................................................................................
    my variable my_variable
    return $my_variable
  }
}

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

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

###
................................................................................
    my variable my_array
    return $my_array($field)
  }
}

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

test clay-class-arrau-0002 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_array timeout
} 10

###
................................................................................
    my variable my_dict
    return [dict get $my_dict {*}$args]
  }
}

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

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

###
................................................................................
# Test dance
test clay-dynamic-ensemble-0003 {Test ensemble with static method} {
  $OBJA myensemble dance
} {1}
test clay-dynamic-ensemble-0004 {Test ensemble with static method} {
  $OBJB myensemble dance
} {0}


###
# Class method testing
###

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

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

  constructor {TkPath args} {
    my variable hull
    set hull $TkPath
    my clay delegate hull $TkPath
  }

  method tkalias tkname {
    set oldname $tkname
    my variable tkalias
    set tkalias $tkname
    set self [self]
    set hullwidget [::info object namespace $self]::tkwidget
    my clay delegate tkwidget $hullwidget
    #rename ::$tkalias $hullwidget
    my clay delegate hullwidget $hullwidget
    #::tool::object_rename [self] ::$tkalias
    rename [self] ::$tkalias
    #my Hull_Bind $tkname
    return $hullwidget
  }
}

test tool-class-method-000 {Test that class methods actually work...} {
  WidgetClass working
} {Works}

test tool-class-method-001 {Test Tk style creator} {
  WidgetClass .foo
  .foo clay delegate hull
} {.foo}

::clay::define WidgetNewClass {
  superclass WidgetClass
}

test tool-class-method-002 {Test Tk style creator inherited by morph} {
  WidgetNewClass .bar
  .bar clay delegate hull
} {.bar}



###
# Test ensemble inheritence
###
clay::define NestedClassA {
  Ensemble do::family {} {
    return NestedClassA
  }
  Ensemble do::something {} {
    return A
  }
  Ensemble do::whop {} {
    return A
  }
}
clay::define NestedClassB {
  superclass NestedClassA
  Ensemble do::family {} {
    set r [next family]
    lappend r NestedClassB
    return $r
  }
  Ensemble do::whop {} {
    return B
  }
}
clay::define NestedClassC {
  superclass NestedClassB

  Ensemble do::somethingelse {} {
    return C
  }
}
clay::define NestedClassD {
  superclass NestedClassB

  Ensemble do::somethingelse {} {
    return D
  }
}

clay::define NestedClassE {
  superclass NestedClassD NestedClassC
}

clay::define NestedClassF {
  superclass NestedClassC NestedClassD
}

NestedClassC create NestedObjectC

###
# These tests no longer work because method ensembles are now dynamically
# generated by object, that are not attached to the class anymore
#
####
#test tool-ensemble-001 {Test that an ensemble can access [next] even if no object of the ancestor class have been instantiated} {
#  NestedObjectC do family
#} {::NestedClassA ::NestedClassB ::NestedClassC}

test tool-ensemble-002 {Test that a later ensemble definition trumps a more primitive one} {
  NestedObjectC do whop
} {B}
test tool-ensemble-003 {Test that an ensemble definitions in an ancestor carry over} {
  NestedObjectC do something
} {A}

NestedClassE create NestedObjectE
NestedClassF create NestedObjectF


test tool-ensemble-004 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectE do somethingelse
} {D}

test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectF do somethingelse
} {C}

###
# Set of tests to exercise the mixinmap system
###
clay::define MixinMainClass {
  Variable mainvar unchanged

  Ensemble test::which {} {
    my variable mainvar
    return $mainvar
  }

  Ensemble test::main args {
    puts [list this is main $method $args]
  }

}

set mixoutscript {my test untool $class}
set mixinscript {my test tool $class}
clay::define MixinTool {
  Variable toolvar unchanged.mixin
  clay set mixin/ unmap-script $mixoutscript
  clay set mixin/ map-script $mixinscript
  clay set mixin/ name {Generic Tool}

  Ensemble test::untool class {
    my variable toolvar mainvar
    set mainvar {}
    set toolvar {}
  }

  Ensemble test::tool class {
    my variable toolvar mainvar
    set mainvar [$class clay get mixin/ name]
    set toolvar [$class clay get mixin/ name]
  }
}

clay::define MixinToolA {
  superclass MixinTool

  clay set mixin/ name {Tool A}
}

clay::define MixinToolB {
  superclass MixinTool

  clay set mixin/ name {Tool B}

  method test_newfunc {} {
    return "B"
  }
}

test tool-mixinspec-001 {Test application of mixin specs} {
  MixinTool clay get mixin/ map-script
} $mixinscript

test tool-mixinspec-002 {Test application of mixin specs} {
  MixinToolA clay get mixin/ map-script
} $mixinscript

test tool-mixinspec-003 {Test application of mixin specs} {
  MixinToolB clay get mixin/ map-script
} $mixinscript


MixinMainClass create mixintest

test tool-mixinmap-001 {Test object prior to mixins} {
  mixintest test which
} {unchanged}

mixintest clay mixinmap tool MixinToolA
test tool-mixinmap-002 {Test mixin map script ran} {
  mixintest test which
} {Tool A}

mixintest clay mixinmap tool MixinToolB

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test which
} {Tool B}

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test_newfunc
} {B}

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


testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

Changes to modules/clay/pkgIndex.tcl. 

7
8
9
10
11
12
13
14
15




# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}


package ifneeded clay 0.2 [list source [file join $dir clay.tcl]]












|

>
>
>

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

# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}


package ifneeded clay 0.3 [list source [file join $dir clay.tcl]]


package ifneeded oo::meta 0.8 [list source [file join $dir clay.tcl]]

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

1
2
3
4
5
6
7
8
9
10
11

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

set version 4.2.0
set tclversion 8.6
set module [file tail $moddir]

set fout [open [file join $moddir ${module}.tcl] w]
dict set map %module% $module
dict set map %version% $version
dict set map %tclversion% $tclversion




|








1
2
3
4
5
6
7
8
9
10
11

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

set version 4.3
set tclversion 8.6
set module [file tail $moddir]

set fout [open [file join $moddir ${module}.tcl] w]
dict set map %module% $module
dict set map %version% $version
dict set map %tclversion% $tclversion

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

1
2
3
4
5
6
7
8
9
10
11
12
..
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
..
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
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102

::clay::define ::httpd::content.cgi {
  superclass ::httpd::content.proxy

  method FileName {} {
    set uri [string trimleft [my clay 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 {[file exists [file join $path $fname]]} {
      return [file join $path $fname]
    }
................................................................................

  method proxy_channel {} {
    ###
    # When delivering static content, allow web caches to save
    ###
    set local_file [my FileName]
    if {$local_file eq {} || ![file exist $local_file]} {
      my log httpNotFound [my clay get REQUEST_URI]
      my error 404 {Not Found}
      tailcall my DoOutput
    }
    if {[file isdirectory $local_file]} {
      ###
      # Produce an index page... or error
      ###
................................................................................
    }
    foreach item $verbatim {
      set ::env($item) {}
    }
    foreach item [array names ::env HTTP_*] {
      set ::env($item) {}
    }
    set ::env(SCRIPT_NAME) [my clay get REQUEST_PATH]
    set ::env(SERVER_PROTOCOL) HTTP/1.0
    set ::env(HOME) $::env(DOCUMENT_ROOT)
    foreach {f v} [my clay dump] {
      if {$f in $verbatim} {
        set ::env($f) $v
      }
    }
  	set arglist $::env(QUERY_STRING)
    set pwd [pwd]
    cd [file dirname $local_file]
    foreach {f v} [my request dump] {
      if {$f in $verbatim} {
        set ::env($f) $v
      } else {
        set ::env(HTTP_$f) $v
      }
    }
    set script_file $local_file
    if {[file extension $local_file] in {.fossil .fos}} {
      if {![file exists $local_file.cgi]} {
        set fout [open $local_file.cgi w]
        chan puts $fout "#!/usr/bin/fossil"
        chan puts $fout "repository: $local_file"
        close $fout
................................................................................
    cd $pwd
    return $pipe
  }

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    set length [my clay get CONTENT_LENGTH]
    if {$length} {
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $chana $chanb -size $length -command [info coroutine]





|







 







|







 







|


|
<
|
<




<
<
<
<
<
<
<







 







|








1
2
3
4
5
6
7
8
9
10
11
12
..
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
..
48
49
50
51
52
53
54
55
56
57
58

59

60
61
62
63







64
65
66
67
68
69
70
..
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93

::clay::define ::httpd::content.cgi {
  superclass ::httpd::content.proxy

  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 {[file exists [file join $path $fname]]} {
      return [file join $path $fname]
    }
................................................................................

  method proxy_channel {} {
    ###
    # When delivering static content, allow web caches to save
    ###
    set local_file [my FileName]
    if {$local_file eq {} || ![file exist $local_file]} {
      my log httpNotFound [my request get REQUEST_URI]
      my error 404 {Not Found}
      tailcall my DoOutput
    }
    if {[file isdirectory $local_file]} {
      ###
      # Produce an index page... or error
      ###
................................................................................
    }
    foreach item $verbatim {
      set ::env($item) {}
    }
    foreach item [array names ::env HTTP_*] {
      set ::env($item) {}
    }
    set ::env(SCRIPT_NAME) [my request get REQUEST_PATH]
    set ::env(SERVER_PROTOCOL) HTTP/1.0
    set ::env(HOME) $::env(DOCUMENT_ROOT)
    foreach {f v} [my request dump] {

      set ::env($f) $v

    }
  	set arglist $::env(QUERY_STRING)
    set pwd [pwd]
    cd [file dirname $local_file]







    set script_file $local_file
    if {[file extension $local_file] in {.fossil .fos}} {
      if {![file exists $local_file.cgi]} {
        set fout [open $local_file.cgi w]
        chan puts $fout "#!/usr/bin/fossil"
        chan puts $fout "repository: $local_file"
        close $fout
................................................................................
    cd $pwd
    return $pipe
  }

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    set length [my request get CONTENT_LENGTH]
    if {$length} {
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $chana $chanb -size $length -command [info coroutine]

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

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
105
106
107
108
109
110
111










112
113
114
115
116
117
118

# support the SCGI module
###

package require uri
package require dns
package require cron
package require coroutine
package require clay
package require mime
package require fileutil
package require websocket
package require Markdown
package require uuid
package require fileutil::magic::filetype

................................................................................
  method HttpHeaders_Default {} {
    return {Status {200 OK}
Content-Size 0
Content-Type {text/html; charset=UTF-8}
Cache-Control {no-cache}
Connection close}
  }











  ###
  # Minimalist MIME Header Parser
  ###
  method MimeParse mimetext {
    set data(mimeorder) {}
    foreach line [split $mimetext \n] {








|







 







>
>
>
>
>
>
>
>
>
>








10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128

# support the SCGI module
###

package require uri
package require dns
package require cron
package require coroutine
package require clay 0.3
package require mime
package require fileutil
package require websocket
package require Markdown
package require uuid
package require fileutil::magic::filetype

................................................................................
  method HttpHeaders_Default {} {
    return {Status {200 OK}
Content-Size 0
Content-Type {text/html; charset=UTF-8}
Cache-Control {no-cache}
Connection close}
  }

  method HttpServerHeaders {} {
    return {
      CONTENT_LENGTH CONTENT_TYPE QUERY_STRING REMOTE_USER AUTH_TYPE
      REQUEST_METHOD REMOTE_ADDR REMOTE_HOST REQUEST_URI REQUEST_PATH
      REQUEST_VERSION  DOCUMENT_ROOT QUERY_STRING REQUEST_RAW
      GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT
      SERVER_NAME  SERVER_SOFTWARE SERVER_PROTOCOL
    }
  }

  ###
  # Minimalist MIME Header Parser
  ###
  method MimeParse mimetext {
    set data(mimeorder) {}
    foreach line [split $mimetext \n] {

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

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

    ###
    # Inject the location into the HTTP headers
    ###
    my variable reply_body
    set reply_body {}
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    set msg [my clay get LOCATION]
    my reply set Location [my clay get LOCATION]
    set code  [my clay get REDIRECT_CODE]
    if {$code eq {}} {
      set code 301
    }
    my reply set Status [list $code [my http_code_string $code]]
  }

  method content {} {
    set template [my <server> template redirect]
    set msg [my clay get LOCATION]
    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}

::clay::define ::httpd::content.cache {

  method dispatch {newsock datastate} {
    my clay replace $datastate
    my request replace  [dict get $datastate http]
    my variable chan
    set chan $newsock
    chan event $chan readable {}
    try {
      my Log_Dispatched
      my wait writable $chan
      chan configure $chan  -translation {binary binary}
      chan puts -nonewline $chan [my clay get CACHE_DATA]
    } on error {err info} {
      my <server> debug [dict get $info -errorinfo]
    } finally {
      my TransferComplete $chan
    }
  }
}

::clay::define ::httpd::content.template {

  method content {} {
    if {[my clay get HTTP_STATUS] ne {}} {
      my reply set Status [my clay get HTTP_STATUS]
    }
    my puts [subst [my <server> template [my clay get template]]]
  }
}








|
|
|








|








<
<




|


|











|
|





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

    ###
    # Inject the location into the HTTP headers
    ###
    my variable reply_body
    set reply_body {}
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    set msg [my request get LOCATION]
    my reply set Location [my request get LOCATION]
    set code  [my request get REDIRECT_CODE]
    if {$code eq {}} {
      set code 301
    }
    my reply set Status [list $code [my http_code_string $code]]
  }

  method content {} {
    set template [my <server> template redirect]
    set msg [my request get LOCATION]
    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}

::clay::define ::httpd::content.cache {

  method dispatch {newsock datastate} {


    my variable chan
    set chan $newsock
    chan event $chan readable {}
    try {
      my request dispatch $datastate
      my wait writable $chan
      chan configure $chan  -translation {binary binary}
      chan puts -nonewline $chan [my clay get cache/ data]
    } on error {err info} {
      my <server> debug [dict get $info -errorinfo]
    } finally {
      my TransferComplete $chan
    }
  }
}

::clay::define ::httpd::content.template {

  method content {} {
    if {[my request get HTTP_STATUS] ne {}} {
      my reply set Status [my request get HTTP_STATUS]
    }
    my puts [subst [my <server> template [my clay get template]]]
  }
}

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

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
..
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
...
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

# 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 clay 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"} {
      return $path
    }
    if {[file exists [file join $path $fname]]} {
................................................................................
    if {[file exists [file join $path $fname.tml]]} {
      return [file join $path $fname.tml]
    }
    return {}
  }

  method DirectoryListing {local_file} {
    set uri [string trimleft [my clay get REQUEST_URI] /]
    set path [my clay get path]
    set prefix [my clay get prefix]
    set fname [string range $uri [string length $prefix] end]
    my puts [my html_header "Listing of /$fname/"]
    my puts "Listing contents of /$fname/"
    my puts "<TABLE>"
    if {$prefix ni {/ {}}} {
................................................................................
    my puts [my html_footer]
  }

  method content {} {
    my variable reply_file
    set local_file [my FileName]
    if {$local_file eq {} || ![file exist $local_file]} {
      my log httpNotFound [my clay get REQUEST_URI]
      my error 404 {File Not Found}
      tailcall my DoOutput
    }
    if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} {
      ###
      # Produce an index page
      ###
................................................................................
        my reply set Content-Type {text/html; charset=UTF-8}
        set mdtxt  [::fileutil::cat $local_file]
        my puts [::Markdown::convert $mdtxt]
      }
      .tml {
        my reply set Content-Type {text/html; charset=UTF-8}
        set tmltxt  [::fileutil::cat $local_file]
        set headers [my clay dump]
        dict with headers {}
        my puts [subst $tmltxt]
      }
      default {
        ###
        # Assume we are returning a binary file
        ###
................................................................................
      }
    }
  }

  method dispatch {newsock datastate} {
    my variable reply_body reply_file reply_chan chan
    try {
      my clay replace $datastate
      my request replace  [dict get $datastate http]
      my Log_Dispatched
      set chan $newsock
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line

      my reset
      # Invoke the URL implementation.
      my content








|







 







|







 







|







 







|







 







|
<
<








2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
..
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
...
105
106
107
108
109
110
111
112


113
114
115
116
117
118
119

# 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"} {
      return $path
    }
    if {[file exists [file join $path $fname]]} {
................................................................................
    if {[file exists [file join $path $fname.tml]]} {
      return [file join $path $fname.tml]
    }
    return {}
  }

  method DirectoryListing {local_file} {
    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]
    my puts [my html_header "Listing of /$fname/"]
    my puts "Listing contents of /$fname/"
    my puts "<TABLE>"
    if {$prefix ni {/ {}}} {
................................................................................
    my puts [my html_footer]
  }

  method content {} {
    my variable reply_file
    set local_file [my FileName]
    if {$local_file eq {} || ![file exist $local_file]} {
      my log httpNotFound [my request get REQUEST_URI]
      my error 404 {File Not Found}
      tailcall my DoOutput
    }
    if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} {
      ###
      # Produce an index page
      ###
................................................................................
        my reply set Content-Type {text/html; charset=UTF-8}
        set mdtxt  [::fileutil::cat $local_file]
        my puts [::Markdown::convert $mdtxt]
      }
      .tml {
        my reply set Content-Type {text/html; charset=UTF-8}
        set tmltxt  [::fileutil::cat $local_file]
        set headers [my request dump]
        dict with headers {}
        my puts [subst $tmltxt]
      }
      default {
        ###
        # Assume we are returning a binary file
        ###
................................................................................
      }
    }
  }

  method dispatch {newsock datastate} {
    my variable reply_body reply_file reply_chan chan
    try {
      my request dispatch $datastate


      set chan $newsock
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line

      my reset
      # Invoke the URL implementation.
      my content

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

44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
...
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

    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }

  method Dispatch_Dict {data} {
    set vhost [lindex [split [dict get $data HTTP_HOST] :] 0]
    set uri   [dict get $data REQUEST_PATH]
    foreach {host pattern info} [my uri patterns] {
      if {![string match $host $vhost]} continue
      if {![string match $pattern $uri]} continue
      set buffer $data
      foreach {f v} $info {
        dict set buffer $f $v
      }
................................................................................

    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    set ip 127.0.0.1
    dict set query UUID $uuid

    dict set query HTTP_HOST       localhost
    dict set query REMOTE_ADDR     127.0.0.1
    dict set query REMOTE_HOST     localhost
    dict set query LOCALHOST 1
    my counter url_hit

    dict set query REQUEST_METHOD  [lindex $args 0]
    set uriinfo [::uri::split [lindex $args 1]]
    dict set query REQUEST_URI     [lindex $args 1]
    dict set query REQUEST_PATH    [dict get $uriinfo path]
    dict set query REQUEST_VERSION [lindex [split [lindex $args end] /] end]
    dict set query DOCUMENT_ROOT   [my clay get server/ doc_root]
    dict set query QUERY_STRING    [dict get $uriinfo query]
    dict set query REQUEST_RAW     $args
    dict set query SERVER_PORT     [my port_listening]
    my Headers_Process query
    set reply [my dispatch $query]

    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }

    set class ::httpd::reply.memchan
    set pageobj [$class create ::httpd::object::$uuid [self]]
    if {[dict exists $reply mixin]} {








|
|







 







>
|
|
|
|


|

|
|
|
|
|
|
|






|








44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
...
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

    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }

  method Dispatch_Dict {data} {
    set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0]
    set uri   [dict get $data http REQUEST_PATH]
    foreach {host pattern info} [my uri patterns] {
      if {![string match $host $vhost]} continue
      if {![string match $pattern $uri]} continue
      set buffer $data
      foreach {f v} $info {
        dict set buffer $f $v
      }
................................................................................

    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    set ip 127.0.0.1
    dict set query UUID $uuid
    dict set query http UUID $uuid
    dict set query http HTTP_HOST       localhost
    dict set query http REMOTE_ADDR     127.0.0.1
    dict set query http REMOTE_HOST     localhost
    dict set query http LOCALHOST 1
    my counter url_hit

    dict set query http REQUEST_METHOD  [lindex $args 0]
    set uriinfo [::uri::split [lindex $args 1]]
    dict set query http REQUEST_URI     [lindex $args 1]
    dict set query http REQUEST_PATH    [dict get $uriinfo path]
    dict set query http REQUEST_VERSION [lindex [split [lindex $args end] /] end]
    dict set query http DOCUMENT_ROOT   [my clay get server/ doc_root]
    dict set query http QUERY_STRING    [dict get $uriinfo query]
    dict set query http REQUEST_RAW     $args
    dict set query http SERVER_PORT     [my port_listening]
    my Headers_Process query
    set reply [my dispatch $query]

    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }

    set class ::httpd::reply.memchan
    set pageobj [$class create ::httpd::object::$uuid [self]]
    if {[dict exists $reply mixin]} {

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

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
...
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168

    # This method returns a channel to the
    # proxied socket/stdout/etc
    ###
    error unimplemented
  }

  method proxy_path {} {
    set uri [string trimleft [my clay get REQUEST_URI] /]
    set prefix [my clay get prefix]
    return /[string range $uri [string length $prefix] end]
  }

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    chan puts $chanb "[my clay get REQUEST_METHOD] [my proxy_path]"

    chan puts $chanb [my clay get mimetxt]
    set length [my clay get CONTENT_LENGTH]
    if {$length} {
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $chana $chanb -size $length -command [info coroutine]
................................................................................
    } else {
      my TransferComplete $chana $chanb
    }
  }

  method dispatch {newsock datastate} {
    try {
      my clay replace $datastate
      my request replace  [dict get $datastate http]
      my Log_Dispatched
      my variable sock chan
      set chan $newsock
      chan configure $chan -translation {auto crlf} -buffering line
      # Initialize the reply
      my reset
      # Invoke the URL implementation.
    } on error {err errdat} {








|







|
>

|







 







|
<
<








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
...
153
154
155
156
157
158
159
160


161
162
163
164
165
166
167

    # This method returns a channel to the
    # proxied socket/stdout/etc
    ###
    error unimplemented
  }

  method proxy_path {} {
    set uri [string trimleft [my request get REQUEST_URI] /]
    set prefix [my clay get prefix]
    return /[string range $uri [string length $prefix] end]
  }

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    chan puts $chanb "[my request get REQUEST_METHOD] [my proxy_path]"
    set mimetxt [my clay get mimetxt]
    chan puts $chanb [my clay get mimetxt]
    set length [my request get CONTENT_LENGTH]
    if {$length} {
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $chana $chanb -size $length -command [info coroutine]
................................................................................
    } else {
      my TransferComplete $chana $chanb
    }
  }

  method dispatch {newsock datastate} {
    try {
      my request dispatch $datastate


      my variable sock chan
      set chan $newsock
      chan configure $chan -translation {auto crlf} -buffering line
      # Initialize the reply
      my reset
      # Invoke the URL implementation.
    } on error {err errdat} {

Changes to modules/httpd/build/reply.inc. 

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
...
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211

clay::define ::test::content.file {
	superclass ::httpd::content.file
	# Return a file
	# Note: this is using the content.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my http_info get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index.html]
	}
}
clay::define ::test::content.time {
  # return the current system time
	method content {} {
................................................................................
    my puts "You Sent<p>"
    my puts "<TABLE>"
    foreach {f v} $form {
      my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
    }
    my puts "</TABLE><p>"
    my puts "Send some info:<p>"
    my puts "<FORM action=/[my http_info get REQUEST_PATH] method POST>"
    my puts "<TABLE>"
    foreach field {name rank serial_number} {
      set line "<TR><TH>$field</TH><TD><input name=\"$field\" "
      if {[dict exists $form $field]} {
        append line " value=\"[dict get $form $field]\"""
      }
      append line " /></TD></TR>"








|







 







|








164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
...
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211

clay::define ::test::content.file {
	superclass ::httpd::content.file
	# Return a file
	# Note: this is using the content.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my clay get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index.html]
	}
}
clay::define ::test::content.time {
  # return the current system time
	method content {} {
................................................................................
    my puts "You Sent<p>"
    my puts "<TABLE>"
    foreach {f v} $form {
      my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
    }
    my puts "</TABLE><p>"
    my puts "Send some info:<p>"
    my puts "<FORM action=/[my request get REQUEST_PATH] method POST>"
    my puts "<TABLE>"
    foreach field {name rank serial_number} {
      set line "<TR><TH>$field</TH><TD><input name=\"$field\" "
      if {[dict exists $form $field]} {
        append line " value=\"[dict get $form $field]\"""
      }
      append line " /></TD></TR>"

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

1
2
3
4
5
6
7




8









9
10
11
12
13
14
15
..
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
...
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
...
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
...
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305


















306
307
308
309
310
311
312
...
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
...
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355

###
# Define the reply class
###
::clay::define ::httpd::reply {
  superclass ::httpd::mime

  variable transfer_complete 0




  clay set CONTENT_LENGTH 0










  constructor {ServerObj args} {
    my variable chan dispatched_time uuid
    set uuid [namespace tail [self]]
    set dispatched_time [clock milliseconds]
    my clay delegate <server> $ServerObj
    foreach {field value} [::clay::args_to_options {*}$args] {
................................................................................
      catch {chan close $chan}
      set chan {}
    }
  }

  method Log_Dispatched {} {
    my log Dispatched [dict create \
     REMOTE_ADDR [my clay get REMOTE_ADDR] \
     REMOTE_HOST [my clay get REMOTE_HOST] \
     COOKIE [my request getnull COOKIE] \
     REFERER [my request getnull REFERER] \
     USER_AGENT [my request getnull USER_AGENT] \
     REQUEST_URI [my clay get REQUEST_URI] \
     HTTP_HOST [my clay get HTTP_HOST] \
     SESSION [my clay get SESSION] \
    ]
  }

  method dispatch {newsock datastate} {
    my clay replace $datastate
    my request replace  [dict getnull $datastate http]
    my Log_Dispatched
    my variable chan
    set chan $newsock
    try {

      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line
      my reset
      # Invoke the URL implementation.
      my content
    } on error {err errdat} {
      my error 500 $err [dict get $errdat -errorinfo]
................................................................................

  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }
    if {![my request exists CONTENT_LENGTH]} {
      set length 0
    } else {
      set length [my request get CONTENT_LENGTH]
    }
    set formdata {}
    if {[my clay get REQUEST_METHOD] in {"POST" "PUSH"}} {
      set rawtype [my request get CONTENT_TYPE]
      if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} {
        set type $rawtype
      } else {
        set type multipart
      }
      switch $type {
................................................................................
  method PostData {length} {
    my variable postdata
    # Run this only once
    if {[info exists postdata]} {
      return $postdata
    }
    set postdata {}
    if {[my clay get REQUEST_METHOD] in {"POST" "PUSH"}} {
      my variable chan
      chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
      set postdata [::coroutine::util::read $chan $length]
    }
    return $postdata
  }

................................................................................
      if {[string tolower $item] eq [string tolower $field]} {
        return $item
      }
    }
    return $field
  }


  Dict request {}

  method request {subcommand args} {
    my variable request
    switch $subcommand {
      dump {
        return $request
      }


















      field {
        tailcall my RequestFind [lindex $args 0]
      }
      get {
        set field [my RequestFind [lindex $args 0]]
        if {![dict exists $request $field]} {
          return {}
................................................................................
      }
      getnull {
        set field [my RequestFind [lindex $args 0]]
        if {![dict exists $request $field]} {
          return {}
        }
        tailcall dict get $request $field

      }
      exists {
        set field [my RequestFind [lindex $args 0]]
        tailcall dict exists $request $field
      }
      parse {
        if {[catch {my MimeParse [lindex $args 0]} result]} {
................................................................................
      }
      default {
        error "Unknown command $subcommand. Valid: field, get, getnull, exists, parse, replace, set"
      }
    }
  }

  Dict reply {}

  method reply {subcommand args} {
    my variable reply
    switch $subcommand {
      dump {
        return $reply
      }
      exists {







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







 







|
|
|
|
|
|
|
|




<
<
<



>







 







<
<
<
|
<

|







 







|







 







<
<
<






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







 







<







 







<
<








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
..
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
...
200
201
202
203
204
205
206



207

208
209
210
211
212
213
214
215
216
...
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
...
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
...
337
338
339
340
341
342
343

344
345
346
347
348
349
350
...
361
362
363
364
365
366
367


368
369
370
371
372
373
374

###
# Define the reply class
###
::clay::define ::httpd::reply {
  superclass ::httpd::mime

  Variable transfer_complete 0

  Dict reply {}

  Dict request {
    CONTENT_LENGTH 0
    COOKIE {}
    HTTP_HOST {}
    REFERER {}
    REQUEST_URI {}
    REMOTE_ADDR {}
    REMOTE_HOST {}
    USER_AGENT {}
    SESSION {}
  }

  constructor {ServerObj args} {
    my variable chan dispatched_time uuid
    set uuid [namespace tail [self]]
    set dispatched_time [clock milliseconds]
    my clay delegate <server> $ServerObj
    foreach {field value} [::clay::args_to_options {*}$args] {
................................................................................
      catch {chan close $chan}
      set chan {}
    }
  }

  method Log_Dispatched {} {
    my log Dispatched [dict create \
     REMOTE_ADDR [my request get REMOTE_ADDR] \
     REMOTE_HOST [my request get REMOTE_HOST] \
     COOKIE [my request get COOKIE] \
     REFERER [my request get REFERER] \
     USER_AGENT [my request get USER_AGENT] \
     REQUEST_URI [my request get REQUEST_URI] \
     HTTP_HOST [my request get HTTP_HOST] \
     SESSION [my request get SESSION] \
    ]
  }

  method dispatch {newsock datastate} {



    my variable chan
    set chan $newsock
    try {
      my request dispatch $datastate
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line
      my reset
      # Invoke the URL implementation.
      my content
    } on error {err errdat} {
      my error 500 $err [dict get $errdat -errorinfo]
................................................................................

  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }



    set length [my request get CONTENT_LENGTH]

    set formdata {}
    if {[my request get REQUEST_METHOD] in {"POST" "PUSH"}} {
      set rawtype [my request get CONTENT_TYPE]
      if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} {
        set type $rawtype
      } else {
        set type multipart
      }
      switch $type {
................................................................................
  method PostData {length} {
    my variable postdata
    # Run this only once
    if {[info exists postdata]} {
      return $postdata
    }
    set postdata {}
    if {[my request get REQUEST_METHOD] in {"POST" "PUSH"}} {
      my variable chan
      chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
      set postdata [::coroutine::util::read $chan $length]
    }
    return $postdata
  }

................................................................................
      if {[string tolower $item] eq [string tolower $field]} {
        return $item
      }
    }
    return $field
  }




  method request {subcommand args} {
    my variable request
    switch $subcommand {
      dump {
        return $request
      }
      dispatch {
        set request [my clay get dict/ request]
        foreach datastate $args {
          foreach {f v} $datastate {
            if {[string index $f end] eq "/"} {
              my clay merge $f $v
            } else {
              my clay set $f $v
            }
            if {$f eq "http"} {
              foreach {ff vf} $v {
                dict set request $ff $vf
              }
            }
          }
        }
        my Log_Dispatched
      }
      field {
        tailcall my RequestFind [lindex $args 0]
      }
      get {
        set field [my RequestFind [lindex $args 0]]
        if {![dict exists $request $field]} {
          return {}
................................................................................
      }
      getnull {
        set field [my RequestFind [lindex $args 0]]
        if {![dict exists $request $field]} {
          return {}
        }
        tailcall dict get $request $field

      }
      exists {
        set field [my RequestFind [lindex $args 0]]
        tailcall dict exists $request $field
      }
      parse {
        if {[catch {my MimeParse [lindex $args 0]} result]} {
................................................................................
      }
      default {
        error "Unknown command $subcommand. Valid: field, get, getnull, exists, parse, replace, set"
      }
    }
  }



  method reply {subcommand args} {
    my variable reply
    switch $subcommand {
      dump {
        return $reply
      }
      exists {

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

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
...
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


  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    set info [dict create CONTENT_LENGTH 0 SCGI 1.0 SCRIPT_NAME [my clay get SCRIPT_NAME]]
    foreach {f v} [my clay dump] {
      dict set info $f $v
    }
    set length [dict get $info CONTENT_LENGTH]
    set block {}
    foreach {f v} $info {
      append block [string toupper $f] \x00 $v \x00
    }
................................................................................
        -blocking 1 \
        -translation {binary binary} \
        -buffersize 4096 \
        -buffering none
    my counter url_hit
    try {
      # Read the SCGI request on byte at a time until we reach a ":"
      dict set query REQUEST_URI /

      dict set query REMOTE_ADDR     $ip

      set size {}
      while 1 {
        set char [::coroutine::util::read $sock 1]
        if {[chan eof $sock]} {
          catch {close $sock}
          return
        }
................................................................................
        if {$char eq ":"} break
        append size $char
      }
      # With length in hand, read the netstring encoded headers
      set inbuffer [::coroutine::util::read $sock [expr {$size+1}]]
      chan configure $sock -blocking 0 -buffersize 4096 -buffering full
      foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] {
        dict set query $f $v
        if {$f in {CONTENT_LENGTH CONTENT_TYPE}} {
          dict set query http $f $v
        } elseif {[string range $f 0 4] eq "HTTP_"} {
          dict set query http [string range $f 5 end] $v
        }
      }
      if {![dict exists $query REQUEST_PATH]} {
        set uri [dict get $query REQUEST_URI]
        set uriinfo [::uri::split $uri]
        dict set query REQUEST_PATH    [dict get $uriinfo path]
      }
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan event readable $sock {}}
      catch {chan event writeable $sock {}}
      catch {chan close $sock}
      return
    }
    if {[dict size $reply]==0} {
      my log BadLocation $uuid $query
      dict set query HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      if {[dict exists $reply class]} {
        set class [dict get $reply class]
      } else {








|







 







|
>
|
>







 







<
<
|
<
<
|
<
|
|

|



|









|








31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
...
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


  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    set info [dict create CONTENT_LENGTH 0 SCGI 1.0 SCRIPT_NAME [my clay get SCRIPT_NAME]]
    foreach {f v} [my request dump] {
      dict set info $f $v
    }
    set length [dict get $info CONTENT_LENGTH]
    set block {}
    foreach {f v} $info {
      append block [string toupper $f] \x00 $v \x00
    }
................................................................................
        -blocking 1 \
        -translation {binary binary} \
        -buffersize 4096 \
        -buffering none
    my counter url_hit
    try {
      # Read the SCGI request on byte at a time until we reach a ":"
      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      dict set query http REQUEST_URI /
      dict set query http REMOTE_ADDR $ip
      set size {}
      while 1 {
        set char [::coroutine::util::read $sock 1]
        if {[chan eof $sock]} {
          catch {close $sock}
          return
        }
................................................................................
        if {$char eq ":"} break
        append size $char
      }
      # With length in hand, read the netstring encoded headers
      set inbuffer [::coroutine::util::read $sock [expr {$size+1}]]
      chan configure $sock -blocking 0 -buffersize 4096 -buffering full
      foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] {


        dict set query http $f $v


      }

      if {![dict exists $query http REQUEST_PATH]} {
        set uri [dict get $query http REQUEST_URI]
        set uriinfo [::uri::split $uri]
        dict set query http REQUEST_PATH    [dict get $uriinfo path]
      }
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query http REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan event readable $sock {}}
      catch {chan event writeable $sock {}}
      catch {chan close $sock}
      return
    }
    if {[dict size $reply]==0} {
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      if {[dict exists $reply class]} {
        set class [dict get $reply class]
      } else {

Changes to modules/httpd/build/server.inc. 

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40


Fields the server are looking for in particular are:

class: A class to use instead of the server's own [arg reply_class]

mixin: A class to be mixed into the new object after construction.

All other fields are passed along to the [cmd http_info] structure of the
reply object.

After the class is created and the mixin is mixed in, the server invokes the
reply objects [cmd dispatch] method. This action passes control of the socket to
the reply object. The reply object manages the rest of the transaction, including
closing the socket.









|








26
27
28
29
30
31
32
33
34
35
36
37
38
39
40


Fields the server are looking for in particular are:

class: A class to use instead of the server's own [arg reply_class]

mixin: A class to be mixed into the new object after construction.

All other fields are passed along to the [cmd clay] structure of the
reply object.

After the class is created and the mixin is mixed in, the server invokes the
reply objects [cmd dispatch] method. This action passes control of the socket to
the reply object. The reply object manages the rest of the transaction, including
closing the socket.

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

11
12
13
14
15
16
17


18
19
20
21
22
23
24
..
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
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
...
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
...
248
249
250
251
252
253
254

255
256
257
258
259
260
261
...
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

  clay set server/ port auto
  clay set server/ myaddr 127.0.0.1
  clay set server/ string [list TclHttpd $::httpd::version]
  clay set server/ name [info hostname]
  clay set server/ doc_root {}
  clay set server/ reverse_dns 0
  clay set server/ configuration_file {}



  clay set socket/ buffersize   32768
  clay set socket/ translation  {auto crlf}
  clay set reply_class ::httpd::reply

  Array template
  Dict url_patterns {}
................................................................................
      -translation {auto crlf} \
      -buffering line

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]
      dict set query UUID $uuid
      dict set query REMOTE_ADDR     $ip
      dict set query REMOTE_HOST     [my HostName $ip]
      dict set query REQUEST_METHOD  [lindex $line 0]
      set uriinfo [::uri::split [lindex $line 1]]
      dict set query REQUEST_URI     [lindex $line 1]
      dict set query REQUEST_PATH    [dict get $uriinfo path]
      dict set query REQUEST_VERSION [lindex [split [lindex $line end] /] end]
      dict set query DOCUMENT_ROOT   [my clay get server/ doc_root]
      dict set query QUERY_STRING    [dict get $uriinfo query]
      dict set query REQUEST_RAW     $line
      dict set query SERVER_PORT     [my port_listening]
      set mimetxt [my HttpHeaders $sock]
      dict set query mimetxt $mimetxt


      foreach {f v} [my MimeParse $mimetxt] {
        set fld [string toupper [string map {- _} $f]]
        if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
          set qfld $fld
        } else {
          set qfld HTTP_$fld
        }


        dict set query $qfld $v
        dict set query http $fld $v




















      }
      if {[string match 127.* $ip]} {
        dict set query LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]
      }
      my Headers_Process query
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}
      return
    }
    if {[dict size $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      if {[dict exists $reply class]} {
        set class [dict get $reply class]
      } else {
................................................................................
    return [my Dispatch_Default $data]
  }

  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [dict get $reply DOCUMENT_ROOT]
    if {$doc_root ne {}} {
      ###
      # Fall back to doc_root handling
      ###
      dict set reply prefix {}
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
................................................................................
    if {$class eq {}} {
      set class ::httpd::plugin.$slot
    }
    if {[info command $class] eq {}} {
      error "Class $class for plugin $slot does not exist"
    }
    my clay mixinmap $slot $class
    set mixinmap [my clay get mixin/]

    ###
    # Perform action on load
    ###
    set script [$class clay search plugin/ load]
    eval $script

................................................................................
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list HEADERS ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"

    oo::objdefine [self] method Headers_Process varname $body

    ###
    # rebuild the Threads_Start method
    ###
    set body "\n try \{"
    foreach {slot class} $mixinmap {
................................................................................
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
    }
    switch $page {
      redirect {
return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my clay get REQUEST_URI]</b> has moved.
<p>
If your browser does not automatically load the new location, it is
<a href=\"$msg\">$msg</a>
[my html footer]
}
      }
      internal_error {
        return {
[my html header "$HTTP_STATUS"]
Error serving <b>[my clay get REQUEST_URI]</b>:
<p>
The server encountered an internal server error: <pre>$msg</pre>
<pre><code>
$errorInfo
</code></pre>
[my html footer]
        }
      }
      notfound {
        return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my clay get REQUEST_URI]</b> does not exist.
[my html footer]
        }
      }
    }
  }

  method Thread_start {} {}








>
>







 







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


>
>







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

|













|







 







|







 







|







 







>







 







|









|











|








11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
..
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
...
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
...
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
...
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
...
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

  clay set server/ port auto
  clay set server/ myaddr 127.0.0.1
  clay set server/ string [list TclHttpd $::httpd::version]
  clay set server/ name [info hostname]
  clay set server/ doc_root {}
  clay set server/ reverse_dns 0
  clay set server/ configuration_file {}
  clay set server/ protocol {HTTP/1.1}
  clay set server/ name     {127.0.0.1}

  clay set socket/ buffersize   32768
  clay set socket/ translation  {auto crlf}
  clay set reply_class ::httpd::reply

  Array template
  Dict url_patterns {}
................................................................................
      -translation {auto crlf} \
      -buffering line

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]












      set mimetxt [my HttpHeaders $sock]
      dict set query mimetxt $mimetxt
      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      foreach {f v} [my MimeParse $mimetxt] {
        set fld [string toupper [string map {- _} $f]]
        if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
          set qfld $fld
        } else {
          set qfld HTTP_$fld
        }
        dict set query http $qfld $v
      }
      dict set query UUID $uuid
      dict set query http UUID $uuid
      dict set query http REMOTE_ADDR     $ip
      dict set query http REMOTE_HOST     [my HostName $ip]
      dict set query http REQUEST_METHOD  [lindex $line 0]
      set uriinfo [::uri::split [lindex $line 1]]
      dict set query uriinfo $uriinfo
      dict set query http REQUEST_URI     [lindex $line 1]
      dict set query http REQUEST_PATH    [dict get $uriinfo path]
      dict set query http REQUEST_VERSION [lindex [split [lindex $line end] /] end]
      dict set query http DOCUMENT_ROOT   [my clay get server/ doc_root]
      dict set query http QUERY_STRING    [dict get $uriinfo query]
      dict set query http REQUEST_RAW     $line
      dict set query http SERVER_PORT     [my port_listening]
      dict set query http SERVER_NAME     [my clay get server/ name]
      dict set query http SERVER_PROTOCOL [my clay get server/ protocol]
      dict set query http SERVER_SOFTWARE [my clay get server/ string]
      # REMOTE_USER AUTH_TYPE
      # GATEWAY_INTERFACE
      # SERVER_HTTPS_PORT
      #SERVER_NAME
      #SERVER_SOFTWARE

      if {[string match 127.* $ip]} {
        dict set query http LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]
      }
      my Headers_Process query
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}
      return
    }
    if {[dict size $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      if {[dict exists $reply class]} {
        set class [dict get $reply class]
      } else {
................................................................................
    return [my Dispatch_Default $data]
  }

  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [my clay get server/ doc_root]
    if {$doc_root ne {}} {
      ###
      # Fall back to doc_root handling
      ###
      dict set reply prefix {}
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
................................................................................
    if {$class eq {}} {
      set class ::httpd::plugin.$slot
    }
    if {[info command $class] eq {}} {
      error "Class $class for plugin $slot does not exist"
    }
    my clay mixinmap $slot $class
    set mixinmap [my clay get mixin]

    ###
    # Perform action on load
    ###
    set script [$class clay search plugin/ load]
    eval $script

................................................................................
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list HEADERS ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"

    oo::objdefine [self] method Headers_Process varname $body

    ###
    # rebuild the Threads_Start method
    ###
    set body "\n try \{"
    foreach {slot class} $mixinmap {
................................................................................
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
    }
    switch $page {
      redirect {
return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> has moved.
<p>
If your browser does not automatically load the new location, it is
<a href=\"$msg\">$msg</a>
[my html footer]
}
      }
      internal_error {
        return {
[my html header "$HTTP_STATUS"]
Error serving <b>[my request get REQUEST_URI]</b>:
<p>
The server encountered an internal server error: <pre>$msg</pre>
<pre><code>
$errorInfo
</code></pre>
[my html footer]
        }
      }
      notfound {
        return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html footer]
        }
      }
    }
  }

  method Thread_start {} {}

Changes to modules/httpd/httpd.tcl. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
...
118
119
120
121
122
123
124










125
126
127
128
129
130
131
...
272
273
274
275
276
277
278
279




280









281
282
283
284
285
286
287
...
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
...
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
...
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
...
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577


















578
579
580
581
582
583
584
...
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
...
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
...
721
722
723
724
725
726
727


728
729
730
731
732
733
734
...
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
...
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
...
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
...
958
959
960
961
962
963
964

965
966
967
968
969
970
971
....
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
....
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
....
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
....
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
....
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
....
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
....
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
....
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464

1465
1466
1467
1468
1469
1470
1471
1472
1473
....
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
....
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
....
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
....
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
....
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
....
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
....
1831
1832
1833
1834
1835
1836
1837
1838

1839

1840
1841
1842
1843
1844
1845
1846
....
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
....
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
....
2098
2099
2100
2101
2102
2103
2104

2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133

###
# Amalgamated package for httpd
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.6
package provide httpd 4.2.0
namespace eval ::httpd {}
set ::httpd::version 4.2.0

###
# START: core.tcl
###
###
# Author: Sean Woods, yoda@etoyoc.com
##
................................................................................
# support the SCGI module
###

package require uri
package require dns
package require cron
package require coroutine
package require clay
package require mime
package require fileutil
package require websocket
package require Markdown
package require uuid
package require fileutil::magic::filetype

................................................................................
  method HttpHeaders_Default {} {
    return {Status {200 OK}
Content-Size 0
Content-Type {text/html; charset=UTF-8}
Cache-Control {no-cache}
Connection close}
  }











  ###
  # Minimalist MIME Header Parser
  ###
  method MimeParse mimetext {
    set data(mimeorder) {}
    foreach line [split $mimetext \n] {
................................................................................
###
###
# Define the reply class
###
::clay::define ::httpd::reply {
  superclass ::httpd::mime

  variable transfer_complete 0




  clay set CONTENT_LENGTH 0










  constructor {ServerObj args} {
    my variable chan dispatched_time uuid
    set uuid [namespace tail [self]]
    set dispatched_time [clock milliseconds]
    my clay delegate <server> $ServerObj
    foreach {field value} [::clay::args_to_options {*}$args] {
................................................................................
      catch {chan close $chan}
      set chan {}
    }
  }

  method Log_Dispatched {} {
    my log Dispatched [dict create \
     REMOTE_ADDR [my clay get REMOTE_ADDR] \
     REMOTE_HOST [my clay get REMOTE_HOST] \
     COOKIE [my request getnull COOKIE] \
     REFERER [my request getnull REFERER] \
     USER_AGENT [my request getnull USER_AGENT] \
     REQUEST_URI [my clay get REQUEST_URI] \
     HTTP_HOST [my clay get HTTP_HOST] \
     SESSION [my clay get SESSION] \
    ]
  }

  method dispatch {newsock datastate} {
    my clay replace $datastate
    my request replace  [dict getnull $datastate http]
    my Log_Dispatched
    my variable chan
    set chan $newsock
    try {

      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line
      my reset
      # Invoke the URL implementation.
      my content
    } on error {err errdat} {
      my error 500 $err [dict get $errdat -errorinfo]
................................................................................

  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }
    if {![my request exists CONTENT_LENGTH]} {
      set length 0
    } else {
      set length [my request get CONTENT_LENGTH]
    }
    set formdata {}
    if {[my clay get REQUEST_METHOD] in {"POST" "PUSH"}} {
      set rawtype [my request get CONTENT_TYPE]
      if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} {
        set type $rawtype
      } else {
        set type multipart
      }
      switch $type {
................................................................................
  method PostData {length} {
    my variable postdata
    # Run this only once
    if {[info exists postdata]} {
      return $postdata
    }
    set postdata {}
    if {[my clay get REQUEST_METHOD] in {"POST" "PUSH"}} {
      my variable chan
      chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
      set postdata [::coroutine::util::read $chan $length]
    }
    return $postdata
  }

................................................................................
      if {[string tolower $item] eq [string tolower $field]} {
        return $item
      }
    }
    return $field
  }


  Dict request {}

  method request {subcommand args} {
    my variable request
    switch $subcommand {
      dump {
        return $request
      }


















      field {
        tailcall my RequestFind [lindex $args 0]
      }
      get {
        set field [my RequestFind [lindex $args 0]]
        if {![dict exists $request $field]} {
          return {}
................................................................................
      }
      getnull {
        set field [my RequestFind [lindex $args 0]]
        if {![dict exists $request $field]} {
          return {}
        }
        tailcall dict get $request $field

      }
      exists {
        set field [my RequestFind [lindex $args 0]]
        tailcall dict exists $request $field
      }
      parse {
        if {[catch {my MimeParse [lindex $args 0]} result]} {
................................................................................
      }
      default {
        error "Unknown command $subcommand. Valid: field, get, getnull, exists, parse, replace, set"
      }
    }
  }

  Dict reply {}

  method reply {subcommand args} {
    my variable reply
    switch $subcommand {
      dump {
        return $reply
      }
      exists {
................................................................................
  clay set server/ port auto
  clay set server/ myaddr 127.0.0.1
  clay set server/ string [list TclHttpd $::httpd::version]
  clay set server/ name [info hostname]
  clay set server/ doc_root {}
  clay set server/ reverse_dns 0
  clay set server/ configuration_file {}



  clay set socket/ buffersize   32768
  clay set socket/ translation  {auto crlf}
  clay set reply_class ::httpd::reply

  Array template
  Dict url_patterns {}
................................................................................
      -translation {auto crlf} \
      -buffering line

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]
      dict set query UUID $uuid
      dict set query REMOTE_ADDR     $ip
      dict set query REMOTE_HOST     [my HostName $ip]
      dict set query REQUEST_METHOD  [lindex $line 0]
      set uriinfo [::uri::split [lindex $line 1]]
      dict set query REQUEST_URI     [lindex $line 1]
      dict set query REQUEST_PATH    [dict get $uriinfo path]
      dict set query REQUEST_VERSION [lindex [split [lindex $line end] /] end]
      dict set query DOCUMENT_ROOT   [my clay get server/ doc_root]
      dict set query QUERY_STRING    [dict get $uriinfo query]
      dict set query REQUEST_RAW     $line
      dict set query SERVER_PORT     [my port_listening]
      set mimetxt [my HttpHeaders $sock]
      dict set query mimetxt $mimetxt


      foreach {f v} [my MimeParse $mimetxt] {
        set fld [string toupper [string map {- _} $f]]
        if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
          set qfld $fld
        } else {
          set qfld HTTP_$fld
        }


        dict set query $qfld $v
        dict set query http $fld $v




















      }
      if {[string match 127.* $ip]} {
        dict set query LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]
      }
      my Headers_Process query
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}
      return
    }
    if {[dict size $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      if {[dict exists $reply class]} {
        set class [dict get $reply class]
      } else {
................................................................................
    return [my Dispatch_Default $data]
  }

  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [dict get $reply DOCUMENT_ROOT]
    if {$doc_root ne {}} {
      ###
      # Fall back to doc_root handling
      ###
      dict set reply prefix {}
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
................................................................................
    if {$class eq {}} {
      set class ::httpd::plugin.$slot
    }
    if {[info command $class] eq {}} {
      error "Class $class for plugin $slot does not exist"
    }
    my clay mixinmap $slot $class
    set mixinmap [my clay get mixin/]

    ###
    # Perform action on load
    ###
    set script [$class clay search plugin/ load]
    eval $script

................................................................................
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list HEADERS ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"

    oo::objdefine [self] method Headers_Process varname $body

    ###
    # rebuild the Threads_Start method
    ###
    set body "\n try \{"
    foreach {slot class} $mixinmap {
................................................................................
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
    }
    switch $page {
      redirect {
return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my clay get REQUEST_URI]</b> has moved.
<p>
If your browser does not automatically load the new location, it is
<a href=\"$msg\">$msg</a>
[my html footer]
}
      }
      internal_error {
        return {
[my html header "$HTTP_STATUS"]
Error serving <b>[my clay get REQUEST_URI]</b>:
<p>
The server encountered an internal server error: <pre>$msg</pre>
<pre><code>
$errorInfo
</code></pre>
[my html footer]
        }
      }
      notfound {
        return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my clay get REQUEST_URI]</b> does not exist.
[my html footer]
        }
      }
    }
  }

  method Thread_start {} {}
................................................................................
    ###
    # Inject the location into the HTTP headers
    ###
    my variable reply_body
    set reply_body {}
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    set msg [my clay get LOCATION]
    my reply set Location [my clay get LOCATION]
    set code  [my clay get REDIRECT_CODE]
    if {$code eq {}} {
      set code 301
    }
    my reply set Status [list $code [my http_code_string $code]]
  }

  method content {} {
    set template [my <server> template redirect]
    set msg [my clay get LOCATION]
    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}

::clay::define ::httpd::content.cache {

  method dispatch {newsock datastate} {
    my clay replace $datastate
    my request replace  [dict get $datastate http]
    my variable chan
    set chan $newsock
    chan event $chan readable {}
    try {
      my Log_Dispatched
      my wait writable $chan
      chan configure $chan  -translation {binary binary}
      chan puts -nonewline $chan [my clay get CACHE_DATA]
    } on error {err info} {
      my <server> debug [dict get $info -errorinfo]
    } finally {
      my TransferComplete $chan
    }
  }
}

::clay::define ::httpd::content.template {

  method content {} {
    if {[my clay get HTTP_STATUS] ne {}} {
      my reply set Status [my clay get HTTP_STATUS]
    }
    my puts [subst [my <server> template [my clay get template]]]
  }
}

###
# END: dispatch.tcl
................................................................................
# 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 clay 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"} {
      return $path
    }
    if {[file exists [file join $path $fname]]} {
................................................................................
    if {[file exists [file join $path $fname.tml]]} {
      return [file join $path $fname.tml]
    }
    return {}
  }

  method DirectoryListing {local_file} {
    set uri [string trimleft [my clay get REQUEST_URI] /]
    set path [my clay get path]
    set prefix [my clay get prefix]
    set fname [string range $uri [string length $prefix] end]
    my puts [my html_header "Listing of /$fname/"]
    my puts "Listing contents of /$fname/"
    my puts "<TABLE>"
    if {$prefix ni {/ {}}} {
................................................................................
    my puts [my html_footer]
  }

  method content {} {
    my variable reply_file
    set local_file [my FileName]
    if {$local_file eq {} || ![file exist $local_file]} {
      my log httpNotFound [my clay get REQUEST_URI]
      my error 404 {File Not Found}
      tailcall my DoOutput
    }
    if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} {
      ###
      # Produce an index page
      ###
................................................................................
        my reply set Content-Type {text/html; charset=UTF-8}
        set mdtxt  [::fileutil::cat $local_file]
        my puts [::Markdown::convert $mdtxt]
      }
      .tml {
        my reply set Content-Type {text/html; charset=UTF-8}
        set tmltxt  [::fileutil::cat $local_file]
        set headers [my clay dump]
        dict with headers {}
        my puts [subst $tmltxt]
      }
      default {
        ###
        # Assume we are returning a binary file
        ###
................................................................................
      }
    }
  }

  method dispatch {newsock datastate} {
    my variable reply_body reply_file reply_chan chan
    try {
      my clay replace $datastate
      my request replace  [dict get $datastate http]
      my Log_Dispatched
      set chan $newsock
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line

      my reset
      # Invoke the URL implementation.
      my content
................................................................................
    # This method returns a channel to the
    # proxied socket/stdout/etc
    ###
    error unimplemented
  }

  method proxy_path {} {
    set uri [string trimleft [my clay get REQUEST_URI] /]
    set prefix [my clay get prefix]
    return /[string range $uri [string length $prefix] end]
  }

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    chan puts $chanb "[my clay get REQUEST_METHOD] [my proxy_path]"

    chan puts $chanb [my clay get mimetxt]
    set length [my clay get CONTENT_LENGTH]
    if {$length} {
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $chana $chanb -size $length -command [info coroutine]
................................................................................
    } else {
      my TransferComplete $chana $chanb
    }
  }

  method dispatch {newsock datastate} {
    try {
      my clay replace $datastate
      my request replace  [dict get $datastate http]
      my Log_Dispatched
      my variable sock chan
      set chan $newsock
      chan configure $chan -translation {auto crlf} -buffering line
      # Initialize the reply
      my reset
      # Invoke the URL implementation.
    } on error {err errdat} {
................................................................................
###
# START: cgi.tcl
###
::clay::define ::httpd::content.cgi {
  superclass ::httpd::content.proxy

  method FileName {} {
    set uri [string trimleft [my clay 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 {[file exists [file join $path $fname]]} {
      return [file join $path $fname]
    }
................................................................................

  method proxy_channel {} {
    ###
    # When delivering static content, allow web caches to save
    ###
    set local_file [my FileName]
    if {$local_file eq {} || ![file exist $local_file]} {
      my log httpNotFound [my clay get REQUEST_URI]
      my error 404 {Not Found}
      tailcall my DoOutput
    }
    if {[file isdirectory $local_file]} {
      ###
      # Produce an index page... or error
      ###
................................................................................
    }
    foreach item $verbatim {
      set ::env($item) {}
    }
    foreach item [array names ::env HTTP_*] {
      set ::env($item) {}
    }
    set ::env(SCRIPT_NAME) [my clay get REQUEST_PATH]
    set ::env(SERVER_PROTOCOL) HTTP/1.0
    set ::env(HOME) $::env(DOCUMENT_ROOT)
    foreach {f v} [my clay dump] {
      if {$f in $verbatim} {
        set ::env($f) $v
      }
    }
  	set arglist $::env(QUERY_STRING)
    set pwd [pwd]
    cd [file dirname $local_file]
    foreach {f v} [my request dump] {
      if {$f in $verbatim} {
        set ::env($f) $v
      } else {
        set ::env(HTTP_$f) $v
      }
    }
    set script_file $local_file
    if {[file extension $local_file] in {.fossil .fos}} {
      if {![file exists $local_file.cgi]} {
        set fout [open $local_file.cgi w]
        chan puts $fout "#!/usr/bin/fossil"
        chan puts $fout "repository: $local_file"
        close $fout
................................................................................
    cd $pwd
    return $pipe
  }

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    set length [my clay get CONTENT_LENGTH]
    if {$length} {
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $chana $chanb -size $length -command [info coroutine]
................................................................................

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    set info [dict create CONTENT_LENGTH 0 SCGI 1.0 SCRIPT_NAME [my clay get SCRIPT_NAME]]
    foreach {f v} [my clay dump] {
      dict set info $f $v
    }
    set length [dict get $info CONTENT_LENGTH]
    set block {}
    foreach {f v} $info {
      append block [string toupper $f] \x00 $v \x00
    }
................................................................................
        -blocking 1 \
        -translation {binary binary} \
        -buffersize 4096 \
        -buffering none
    my counter url_hit
    try {
      # Read the SCGI request on byte at a time until we reach a ":"
      dict set query REQUEST_URI /

      dict set query REMOTE_ADDR     $ip

      set size {}
      while 1 {
        set char [::coroutine::util::read $sock 1]
        if {[chan eof $sock]} {
          catch {close $sock}
          return
        }
................................................................................
        if {$char eq ":"} break
        append size $char
      }
      # With length in hand, read the netstring encoded headers
      set inbuffer [::coroutine::util::read $sock [expr {$size+1}]]
      chan configure $sock -blocking 0 -buffersize 4096 -buffering full
      foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] {
        dict set query $f $v
        if {$f in {CONTENT_LENGTH CONTENT_TYPE}} {
          dict set query http $f $v
        } elseif {[string range $f 0 4] eq "HTTP_"} {
          dict set query http [string range $f 5 end] $v
        }
      }
      if {![dict exists $query REQUEST_PATH]} {
        set uri [dict get $query REQUEST_URI]
        set uriinfo [::uri::split $uri]
        dict set query REQUEST_PATH    [dict get $uriinfo path]
      }
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan event readable $sock {}}
      catch {chan event writeable $sock {}}
      catch {chan close $sock}
      return
    }
    if {[dict size $reply]==0} {
      my log BadLocation $uuid $query
      dict set query HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      if {[dict exists $reply class]} {
        set class [dict get $reply class]
      } else {
................................................................................
    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }

  method Dispatch_Dict {data} {
    set vhost [lindex [split [dict get $data HTTP_HOST] :] 0]
    set uri   [dict get $data REQUEST_PATH]
    foreach {host pattern info} [my uri patterns] {
      if {![string match $host $vhost]} continue
      if {![string match $pattern $uri]} continue
      set buffer $data
      foreach {f v} $info {
        dict set buffer $f $v
      }
................................................................................

    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    set ip 127.0.0.1
    dict set query UUID $uuid

    dict set query HTTP_HOST       localhost
    dict set query REMOTE_ADDR     127.0.0.1
    dict set query REMOTE_HOST     localhost
    dict set query LOCALHOST 1
    my counter url_hit

    dict set query REQUEST_METHOD  [lindex $args 0]
    set uriinfo [::uri::split [lindex $args 1]]
    dict set query REQUEST_URI     [lindex $args 1]
    dict set query REQUEST_PATH    [dict get $uriinfo path]
    dict set query REQUEST_VERSION [lindex [split [lindex $args end] /] end]
    dict set query DOCUMENT_ROOT   [my clay get server/ doc_root]
    dict set query QUERY_STRING    [dict get $uriinfo query]
    dict set query REQUEST_RAW     $args
    dict set query SERVER_PORT     [my port_listening]
    my Headers_Process query
    set reply [my dispatch $query]

    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }

    set class ::httpd::reply.memchan
    set pageobj [$class create ::httpd::object::$uuid [self]]
    if {[dict exists $reply mixin]} {







|

|







 







|







 







>
>
>
>
>
>
>
>
>
>







 







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







 







|
|
|
|
|
|
|
|




<
<
<



>







 







<
<
<
|
<

|







 







|







 







<
<
<






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







 







<







 







<
<







 







>
>







 







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


>
>







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

|













|







 







|







 







|







 







>







 







|









|











|







 







|
|
|








|








<
<




|


|











|
|







 







|







 







|







 







|







 







|







 







|
<
<







 







|







|
>

|







 







|
<
<







 







|







 







|







 







|


|
<
|
<




<
<
<
<
<
<
<







 







|







 







|







 







|
>
|
>







 







<
<
|
<
<
|
<
|
|

|



|









|







 







|
|







 







>
|
|
|
|


|

|
|
|
|
|
|
|






|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
...
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
...
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
...
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
...
482
483
484
485
486
487
488



489

490
491
492
493
494
495
496
497
498
...
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
...
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
...
619
620
621
622
623
624
625

626
627
628
629
630
631
632
...
643
644
645
646
647
648
649


650
651
652
653
654
655
656
...
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
...
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
...
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
...
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
....
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
....
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
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
....
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198


1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
....
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
....
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
....
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
....
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
....
1335
1336
1337
1338
1339
1340
1341
1342


1343
1344
1345
1346
1347
1348
1349
....
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
....
1549
1550
1551
1552
1553
1554
1555
1556


1557
1558
1559
1560
1561
1562
1563
....
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
....
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
....
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646

1647

1648
1649
1650
1651







1652
1653
1654
1655
1656
1657
1658
....
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
....
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
....
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
....
1879
1880
1881
1882
1883
1884
1885


1886


1887

1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
....
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
....
2125
2126
2127
2128
2129
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

###
# Amalgamated package for httpd
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.6
package provide httpd 4.3
namespace eval ::httpd {}
set ::httpd::version 4.3

###
# START: core.tcl
###
###
# Author: Sean Woods, yoda@etoyoc.com
##
................................................................................
# support the SCGI module
###

package require uri
package require dns
package require cron
package require coroutine
package require clay 0.3
package require mime
package require fileutil
package require websocket
package require Markdown
package require uuid
package require fileutil::magic::filetype

................................................................................
  method HttpHeaders_Default {} {
    return {Status {200 OK}
Content-Size 0
Content-Type {text/html; charset=UTF-8}
Cache-Control {no-cache}
Connection close}
  }

  method HttpServerHeaders {} {
    return {
      CONTENT_LENGTH CONTENT_TYPE QUERY_STRING REMOTE_USER AUTH_TYPE
      REQUEST_METHOD REMOTE_ADDR REMOTE_HOST REQUEST_URI REQUEST_PATH
      REQUEST_VERSION  DOCUMENT_ROOT QUERY_STRING REQUEST_RAW
      GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT
      SERVER_NAME  SERVER_SOFTWARE SERVER_PROTOCOL
    }
  }

  ###
  # Minimalist MIME Header Parser
  ###
  method MimeParse mimetext {
    set data(mimeorder) {}
    foreach line [split $mimetext \n] {
................................................................................
###
###
# Define the reply class
###
::clay::define ::httpd::reply {
  superclass ::httpd::mime

  Variable transfer_complete 0

  Dict reply {}

  Dict request {
    CONTENT_LENGTH 0
    COOKIE {}
    HTTP_HOST {}
    REFERER {}
    REQUEST_URI {}
    REMOTE_ADDR {}
    REMOTE_HOST {}
    USER_AGENT {}
    SESSION {}
  }

  constructor {ServerObj args} {
    my variable chan dispatched_time uuid
    set uuid [namespace tail [self]]
    set dispatched_time [clock milliseconds]
    my clay delegate <server> $ServerObj
    foreach {field value} [::clay::args_to_options {*}$args] {
................................................................................
      catch {chan close $chan}
      set chan {}
    }
  }

  method Log_Dispatched {} {
    my log Dispatched [dict create \
     REMOTE_ADDR [my request get REMOTE_ADDR] \
     REMOTE_HOST [my request get REMOTE_HOST] \
     COOKIE [my request get COOKIE] \
     REFERER [my request get REFERER] \
     USER_AGENT [my request get USER_AGENT] \
     REQUEST_URI [my request get REQUEST_URI] \
     HTTP_HOST [my request get HTTP_HOST] \
     SESSION [my request get SESSION] \
    ]
  }

  method dispatch {newsock datastate} {



    my variable chan
    set chan $newsock
    try {
      my request dispatch $datastate
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line
      my reset
      # Invoke the URL implementation.
      my content
    } on error {err errdat} {
      my error 500 $err [dict get $errdat -errorinfo]
................................................................................

  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }



    set length [my request get CONTENT_LENGTH]

    set formdata {}
    if {[my request get REQUEST_METHOD] in {"POST" "PUSH"}} {
      set rawtype [my request get CONTENT_TYPE]
      if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} {
        set type $rawtype
      } else {
        set type multipart
      }
      switch $type {
................................................................................
  method PostData {length} {
    my variable postdata
    # Run this only once
    if {[info exists postdata]} {
      return $postdata
    }
    set postdata {}
    if {[my request get REQUEST_METHOD] in {"POST" "PUSH"}} {
      my variable chan
      chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
      set postdata [::coroutine::util::read $chan $length]
    }
    return $postdata
  }

................................................................................
      if {[string tolower $item] eq [string tolower $field]} {
        return $item
      }
    }
    return $field
  }




  method request {subcommand args} {
    my variable request
    switch $subcommand {
      dump {
        return $request
      }
      dispatch {
        set request [my clay get dict/ request]
        foreach datastate $args {
          foreach {f v} $datastate {
            if {[string index $f end] eq "/"} {
              my clay merge $f $v
            } else {
              my clay set $f $v
            }
            if {$f eq "http"} {
              foreach {ff vf} $v {
                dict set request $ff $vf
              }
            }
          }
        }
        my Log_Dispatched
      }
      field {
        tailcall my RequestFind [lindex $args 0]
      }
      get {
        set field [my RequestFind [lindex $args 0]]
        if {![dict exists $request $field]} {
          return {}
................................................................................
      }
      getnull {
        set field [my RequestFind [lindex $args 0]]
        if {![dict exists $request $field]} {
          return {}
        }
        tailcall dict get $request $field

      }
      exists {
        set field [my RequestFind [lindex $args 0]]
        tailcall dict exists $request $field
      }
      parse {
        if {[catch {my MimeParse [lindex $args 0]} result]} {
................................................................................
      }
      default {
        error "Unknown command $subcommand. Valid: field, get, getnull, exists, parse, replace, set"
      }
    }
  }



  method reply {subcommand args} {
    my variable reply
    switch $subcommand {
      dump {
        return $reply
      }
      exists {
................................................................................
  clay set server/ port auto
  clay set server/ myaddr 127.0.0.1
  clay set server/ string [list TclHttpd $::httpd::version]
  clay set server/ name [info hostname]
  clay set server/ doc_root {}
  clay set server/ reverse_dns 0
  clay set server/ configuration_file {}
  clay set server/ protocol {HTTP/1.1}
  clay set server/ name     {127.0.0.1}

  clay set socket/ buffersize   32768
  clay set socket/ translation  {auto crlf}
  clay set reply_class ::httpd::reply

  Array template
  Dict url_patterns {}
................................................................................
      -translation {auto crlf} \
      -buffering line

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]












      set mimetxt [my HttpHeaders $sock]
      dict set query mimetxt $mimetxt
      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      foreach {f v} [my MimeParse $mimetxt] {
        set fld [string toupper [string map {- _} $f]]
        if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
          set qfld $fld
        } else {
          set qfld HTTP_$fld
        }
        dict set query http $qfld $v
      }
      dict set query UUID $uuid
      dict set query http UUID $uuid
      dict set query http REMOTE_ADDR     $ip
      dict set query http REMOTE_HOST     [my HostName $ip]
      dict set query http REQUEST_METHOD  [lindex $line 0]
      set uriinfo [::uri::split [lindex $line 1]]
      dict set query uriinfo $uriinfo
      dict set query http REQUEST_URI     [lindex $line 1]
      dict set query http REQUEST_PATH    [dict get $uriinfo path]
      dict set query http REQUEST_VERSION [lindex [split [lindex $line end] /] end]
      dict set query http DOCUMENT_ROOT   [my clay get server/ doc_root]
      dict set query http QUERY_STRING    [dict get $uriinfo query]
      dict set query http REQUEST_RAW     $line
      dict set query http SERVER_PORT     [my port_listening]
      dict set query http SERVER_NAME     [my clay get server/ name]
      dict set query http SERVER_PROTOCOL [my clay get server/ protocol]
      dict set query http SERVER_SOFTWARE [my clay get server/ string]
      # REMOTE_USER AUTH_TYPE
      # GATEWAY_INTERFACE
      # SERVER_HTTPS_PORT
      #SERVER_NAME
      #SERVER_SOFTWARE

      if {[string match 127.* $ip]} {
        dict set query http LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]
      }
      my Headers_Process query
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}
      return
    }
    if {[dict size $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      if {[dict exists $reply class]} {
        set class [dict get $reply class]
      } else {
................................................................................
    return [my Dispatch_Default $data]
  }

  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [my clay get server/ doc_root]
    if {$doc_root ne {}} {
      ###
      # Fall back to doc_root handling
      ###
      dict set reply prefix {}
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
................................................................................
    if {$class eq {}} {
      set class ::httpd::plugin.$slot
    }
    if {[info command $class] eq {}} {
      error "Class $class for plugin $slot does not exist"
    }
    my clay mixinmap $slot $class
    set mixinmap [my clay get mixin]

    ###
    # Perform action on load
    ###
    set script [$class clay search plugin/ load]
    eval $script

................................................................................
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list HEADERS ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"

    oo::objdefine [self] method Headers_Process varname $body

    ###
    # rebuild the Threads_Start method
    ###
    set body "\n try \{"
    foreach {slot class} $mixinmap {
................................................................................
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
    }
    switch $page {
      redirect {
return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> has moved.
<p>
If your browser does not automatically load the new location, it is
<a href=\"$msg\">$msg</a>
[my html footer]
}
      }
      internal_error {
        return {
[my html header "$HTTP_STATUS"]
Error serving <b>[my request get REQUEST_URI]</b>:
<p>
The server encountered an internal server error: <pre>$msg</pre>
<pre><code>
$errorInfo
</code></pre>
[my html footer]
        }
      }
      notfound {
        return {
[my html header "$HTTP_STATUS"]
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html footer]
        }
      }
    }
  }

  method Thread_start {} {}
................................................................................
    ###
    # Inject the location into the HTTP headers
    ###
    my variable reply_body
    set reply_body {}
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    set msg [my request get LOCATION]
    my reply set Location [my request get LOCATION]
    set code  [my request get REDIRECT_CODE]
    if {$code eq {}} {
      set code 301
    }
    my reply set Status [list $code [my http_code_string $code]]
  }

  method content {} {
    set template [my <server> template redirect]
    set msg [my request get LOCATION]
    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}

::clay::define ::httpd::content.cache {

  method dispatch {newsock datastate} {


    my variable chan
    set chan $newsock
    chan event $chan readable {}
    try {
      my request dispatch $datastate
      my wait writable $chan
      chan configure $chan  -translation {binary binary}
      chan puts -nonewline $chan [my clay get cache/ data]
    } on error {err info} {
      my <server> debug [dict get $info -errorinfo]
    } finally {
      my TransferComplete $chan
    }
  }
}

::clay::define ::httpd::content.template {

  method content {} {
    if {[my request get HTTP_STATUS] ne {}} {
      my reply set Status [my request get HTTP_STATUS]
    }
    my puts [subst [my <server> template [my clay get template]]]
  }
}

###
# END: dispatch.tcl
................................................................................
# 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"} {
      return $path
    }
    if {[file exists [file join $path $fname]]} {
................................................................................
    if {[file exists [file join $path $fname.tml]]} {
      return [file join $path $fname.tml]
    }
    return {}
  }

  method DirectoryListing {local_file} {
    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]
    my puts [my html_header "Listing of /$fname/"]
    my puts "Listing contents of /$fname/"
    my puts "<TABLE>"
    if {$prefix ni {/ {}}} {
................................................................................
    my puts [my html_footer]
  }

  method content {} {
    my variable reply_file
    set local_file [my FileName]
    if {$local_file eq {} || ![file exist $local_file]} {
      my log httpNotFound [my request get REQUEST_URI]
      my error 404 {File Not Found}
      tailcall my DoOutput
    }
    if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} {
      ###
      # Produce an index page
      ###
................................................................................
        my reply set Content-Type {text/html; charset=UTF-8}
        set mdtxt  [::fileutil::cat $local_file]
        my puts [::Markdown::convert $mdtxt]
      }
      .tml {
        my reply set Content-Type {text/html; charset=UTF-8}
        set tmltxt  [::fileutil::cat $local_file]
        set headers [my request dump]
        dict with headers {}
        my puts [subst $tmltxt]
      }
      default {
        ###
        # Assume we are returning a binary file
        ###
................................................................................
      }
    }
  }

  method dispatch {newsock datastate} {
    my variable reply_body reply_file reply_chan chan
    try {
      my request dispatch $datastate


      set chan $newsock
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line

      my reset
      # Invoke the URL implementation.
      my content
................................................................................
    # This method returns a channel to the
    # proxied socket/stdout/etc
    ###
    error unimplemented
  }

  method proxy_path {} {
    set uri [string trimleft [my request get REQUEST_URI] /]
    set prefix [my clay get prefix]
    return /[string range $uri [string length $prefix] end]
  }

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    chan puts $chanb "[my request get REQUEST_METHOD] [my proxy_path]"
    set mimetxt [my clay get mimetxt]
    chan puts $chanb [my clay get mimetxt]
    set length [my request get CONTENT_LENGTH]
    if {$length} {
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $chana $chanb -size $length -command [info coroutine]
................................................................................
    } else {
      my TransferComplete $chana $chanb
    }
  }

  method dispatch {newsock datastate} {
    try {
      my request dispatch $datastate


      my variable sock chan
      set chan $newsock
      chan configure $chan -translation {auto crlf} -buffering line
      # Initialize the reply
      my reset
      # Invoke the URL implementation.
    } on error {err errdat} {
................................................................................
###
# START: cgi.tcl
###
::clay::define ::httpd::content.cgi {
  superclass ::httpd::content.proxy

  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 {[file exists [file join $path $fname]]} {
      return [file join $path $fname]
    }
................................................................................

  method proxy_channel {} {
    ###
    # When delivering static content, allow web caches to save
    ###
    set local_file [my FileName]
    if {$local_file eq {} || ![file exist $local_file]} {
      my log httpNotFound [my request get REQUEST_URI]
      my error 404 {Not Found}
      tailcall my DoOutput
    }
    if {[file isdirectory $local_file]} {
      ###
      # Produce an index page... or error
      ###
................................................................................
    }
    foreach item $verbatim {
      set ::env($item) {}
    }
    foreach item [array names ::env HTTP_*] {
      set ::env($item) {}
    }
    set ::env(SCRIPT_NAME) [my request get REQUEST_PATH]
    set ::env(SERVER_PROTOCOL) HTTP/1.0
    set ::env(HOME) $::env(DOCUMENT_ROOT)
    foreach {f v} [my request dump] {

      set ::env($f) $v

    }
  	set arglist $::env(QUERY_STRING)
    set pwd [pwd]
    cd [file dirname $local_file]







    set script_file $local_file
    if {[file extension $local_file] in {.fossil .fos}} {
      if {![file exists $local_file.cgi]} {
        set fout [open $local_file.cgi w]
        chan puts $fout "#!/usr/bin/fossil"
        chan puts $fout "repository: $local_file"
        close $fout
................................................................................
    cd $pwd
    return $pipe
  }

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    set length [my request get CONTENT_LENGTH]
    if {$length} {
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $chana $chanb -size $length -command [info coroutine]
................................................................................

  method ProxyRequest {chana chanb} {
    chan event $chanb writable {}
    my log ProxyRequest {}
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    set info [dict create CONTENT_LENGTH 0 SCGI 1.0 SCRIPT_NAME [my clay get SCRIPT_NAME]]
    foreach {f v} [my request dump] {
      dict set info $f $v
    }
    set length [dict get $info CONTENT_LENGTH]
    set block {}
    foreach {f v} $info {
      append block [string toupper $f] \x00 $v \x00
    }
................................................................................
        -blocking 1 \
        -translation {binary binary} \
        -buffersize 4096 \
        -buffering none
    my counter url_hit
    try {
      # Read the SCGI request on byte at a time until we reach a ":"
      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      dict set query http REQUEST_URI /
      dict set query http REMOTE_ADDR $ip
      set size {}
      while 1 {
        set char [::coroutine::util::read $sock 1]
        if {[chan eof $sock]} {
          catch {close $sock}
          return
        }
................................................................................
        if {$char eq ":"} break
        append size $char
      }
      # With length in hand, read the netstring encoded headers
      set inbuffer [::coroutine::util::read $sock [expr {$size+1}]]
      chan configure $sock -blocking 0 -buffersize 4096 -buffering full
      foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] {


        dict set query http $f $v


      }

      if {![dict exists $query http REQUEST_PATH]} {
        set uri [dict get $query http REQUEST_URI]
        set uriinfo [::uri::split $uri]
        dict set query http REQUEST_PATH    [dict get $uriinfo path]
      }
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query http REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan event readable $sock {}}
      catch {chan event writeable $sock {}}
      catch {chan close $sock}
      return
    }
    if {[dict size $reply]==0} {
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      if {[dict exists $reply class]} {
        set class [dict get $reply class]
      } else {
................................................................................
    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }

  method Dispatch_Dict {data} {
    set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0]
    set uri   [dict get $data http REQUEST_PATH]
    foreach {host pattern info} [my uri patterns] {
      if {![string match $host $vhost]} continue
      if {![string match $pattern $uri]} continue
      set buffer $data
      foreach {f v} $info {
        dict set buffer $f $v
      }
................................................................................

    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    set ip 127.0.0.1
    dict set query UUID $uuid
    dict set query http UUID $uuid
    dict set query http HTTP_HOST       localhost
    dict set query http REMOTE_ADDR     127.0.0.1
    dict set query http REMOTE_HOST     localhost
    dict set query http LOCALHOST 1
    my counter url_hit

    dict set query http REQUEST_METHOD  [lindex $args 0]
    set uriinfo [::uri::split [lindex $args 1]]
    dict set query http REQUEST_URI     [lindex $args 1]
    dict set query http REQUEST_PATH    [dict get $uriinfo path]
    dict set query http REQUEST_VERSION [lindex [split [lindex $args end] /] end]
    dict set query http DOCUMENT_ROOT   [my clay get server/ doc_root]
    dict set query http QUERY_STRING    [dict get $uriinfo query]
    dict set query http REQUEST_RAW     $args
    dict set query http SERVER_PORT     [my port_listening]
    my Headers_Process query
    set reply [my dispatch $query]

    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }

    set class ::httpd::reply.memchan
    set pageobj [$class create ::httpd::object::$uuid [self]]
    if {[dict exists $reply mixin]} {

Changes to modules/httpd/httpd.test. 

241
242
243
244
245
246
247

248
249
250
251
252
253
254
...
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
...
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
...
583
584
585
586
587
588
589

590
591
592
593
594
595
596

::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
Content-Length: *

THIS IS MY CODE}
} {}


::DEBUG puts httpd-client-0002
test httpd-client-0002 {Do another echo request} {
set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT}]
::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
................................................................................

::DEBUG puts httpd-client-0006
test httpd-client-0006 {Return a file} {
set reply [::httpd::test::send 10001 {GET /file HTTP/1.0} {} {}]
::httpd::test::compare $reply $checkreply
} {}


# -------------------------------------------------------------------------
# Test proxies

clay::define ::test::content.proxy {
	superclass ::httpd::content.proxy


  method proxy_channel {} {
    return [::socket localhost [my clay get proxy_port]]
  }
}


................................................................................
$replyfile"

::DEBUG puts httpd-proxy-0006
test httpd-proxy-0006 {Return a file} {
set reply [::httpd::test::send 10001 {GET /proxy/file HTTP/1.0} {} {}]
::httpd::test::compare $reply $checkreply
} {}



# -------------------------------------------------------------------------
# cgi
TESTAPP plugin local_memchan

TESTAPP uri add /cgi-bin* [list mixin {reply ::test::content.cgi} path $::DEMOROOT]

................................................................................
Content-Type: text/plain
Connection: close
Content-Length: *

THIS IS MY CODE}
::httpd::test::compare $reply $checkreply
} {}


::DEBUG puts scgi-client-0002
test scgi-client-0002 {Do another echo request} {
set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THOUGH THERE ARE MANY LIKE IT}]
set checkreply {Status: 200 OK
Content-Type: text/plain
Connection: close








>







 







<





<







 







<
<







 







>








241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
...
307
308
309
310
311
312
313

314
315
316
317
318

319
320
321
322
323
324
325
...
403
404
405
406
407
408
409


410
411
412
413
414
415
416
...
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594

::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
Content-Length: *

THIS IS MY CODE}
} {}


::DEBUG puts httpd-client-0002
test httpd-client-0002 {Do another echo request} {
set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT}]
::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
................................................................................

::DEBUG puts httpd-client-0006
test httpd-client-0006 {Return a file} {
set reply [::httpd::test::send 10001 {GET /file HTTP/1.0} {} {}]
::httpd::test::compare $reply $checkreply
} {}


# -------------------------------------------------------------------------
# Test proxies

clay::define ::test::content.proxy {
	superclass ::httpd::content.proxy


  method proxy_channel {} {
    return [::socket localhost [my clay get proxy_port]]
  }
}


................................................................................
$replyfile"

::DEBUG puts httpd-proxy-0006
test httpd-proxy-0006 {Return a file} {
set reply [::httpd::test::send 10001 {GET /proxy/file HTTP/1.0} {} {}]
::httpd::test::compare $reply $checkreply
} {}



# -------------------------------------------------------------------------
# cgi
TESTAPP plugin local_memchan

TESTAPP uri add /cgi-bin* [list mixin {reply ::test::content.cgi} path $::DEMOROOT]

................................................................................
Content-Type: text/plain
Connection: close
Content-Length: *

THIS IS MY CODE}
::httpd::test::compare $reply $checkreply
} {}


::DEBUG puts scgi-client-0002
test scgi-client-0002 {Do another echo request} {
set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THOUGH THERE ARE MANY LIKE IT}]
set checkreply {Status: 200 OK
Content-Type: text/plain
Connection: close

Changes to modules/httpd/pkgIndex.tcl. 

1
2
3
4


if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded httpd 4.2.0 [list source [file join $dir httpd.tcl]]




|


1
2
3
4


if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded httpd 4.3 [list source [file join $dir httpd.tcl]]

Changes to modules/practcl/practcl.tcl. 

734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
....
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
2231
2232
2233
....
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
....
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
....
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
....
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
....
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
....
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
....
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
....
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
....
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
....
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192

            }
            break
          }
        }
      }
      mixinmap {
        foreach {slot classes} $args {
          dict set clay mixin/ $slot $classes
        }
        set claycache {}
        set classlist {}
        foreach {item class} [my clay get mixin/] {
          if {$class ne {}} {
            lappend classlist $class
          }
        }
        my clay mixin {*}$classlist
      }
      provenance {
................................................................................
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 {


................................................................................

  # MSVC always builds in the source directory
  method BuildDir {PWD} {
    set srcdir [my define get srcdir]
    return $srcdir
  }

  
  # Do nothing
  method make-autodetect {} {
  }
  
  method make-clean {} {
    set PWD [pwd]
    set srcdir [my define get srcdir]
    cd $srcdir
    catch {::practcl::doexec nmake -f makefile.vc clean}
    cd $PWD
  }
  
  method make-compile {} {
    set srcdir [my define get srcdir]
    if {[my define get static 1]} {
      puts "BUILDING Static $name $srcdir"
    } else {
      puts "BUILDING Dynamic $name $srcdir"
    }
................................................................................
        cd [file join $srcdir win]
        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir]  {*}[my NmakeOpts] release
      } else {
        error "No make.tcl or makefile.vc found for project $name"
      }
    }
  }
  
  method make-install DEST {
    set PWD [pwd]
    set srcdir [my define get srcdir]
    cd $srcdir
    if {$DEST eq {}} {
      error "No destination given"
    }
................................................................................
      } else {
        puts "[self] VFS INSTALL $DEST"
        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install
      }
    }
    cd $PWD
  }
  
  # Detect what directory contains the Makefile template
  method MakeDir {srcdir} {
    set localsrcdir $srcdir
    if {[file exists [file join $srcdir generic]]} {
      my define add include_dir [file join $srcdir generic]
    }
    if {[file exists [file join $srcdir win]]} {
................................................................................
       my define add include_dir [file join $srcdir win]
    }
    if {[file exists [file join $srcdir makefile.vc]]} {
      set localsrcdir [file join $srcdir win]
    }
    return $localsrcdir
  }
  
  method NmakeOpts {} {
    set opts {}
    set builddir [file normalize [my define get builddir]]

    if {[my <project> define exists tclsrcdir]} {
      ###
      # On Windows we are probably running under MSYS, which doesn't deal with
................................................................................
        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]
................................................................................
    foreach {f v} $argdat {
      dict set cstruct $name $f $v
    }
    if {![dict exists $cstruct $name public]} {
      dict set cstruct $name public 1
    }
  }
  
  method include header {
    my define add include $header
  }

  method include_dir args {
    my define add include_dir {*}$args
  }
................................................................................
      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]
................................................................................
    set info [next]
    dict set info scm fossil
    foreach {field value} [::practcl::fossil_status [my define get srcdir]] {
      dict set info $field $value
    }
    return $info
  }
  
  # Clone the source
  method ScmClone  {} {
    set srcdir [my SrcDir]
    if {[file exists [file join $srcdir .fslckout]]} {
      return
    }
    if {[file exists [file join $srcdir _FOSSIL_]]} {








|



|







 







|












|



|







 







|







 







|



|







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|








734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
....
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
2231
2232
2233
....
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
....
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
....
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
....
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
....
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
....
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
....
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
....
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
....
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
....
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192

            }
            break
          }
        }
      }
      mixinmap {
        foreach {slot classes} $args {
          dict set clay mixin $slot $classes
        }
        set claycache {}
        set classlist {}
        foreach {item class} [my clay get mixin] {
          if {$class ne {}} {
            lappend classlist $class
          }
        }
        my clay mixin {*}$classlist
      }
      provenance {
................................................................................
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 {


................................................................................

  # MSVC always builds in the source directory
  method BuildDir {PWD} {
    set srcdir [my define get srcdir]
    return $srcdir
  }


  # Do nothing
  method make-autodetect {} {
  }

  method make-clean {} {
    set PWD [pwd]
    set srcdir [my define get srcdir]
    cd $srcdir
    catch {::practcl::doexec nmake -f makefile.vc clean}
    cd $PWD
  }

  method make-compile {} {
    set srcdir [my define get srcdir]
    if {[my define get static 1]} {
      puts "BUILDING Static $name $srcdir"
    } else {
      puts "BUILDING Dynamic $name $srcdir"
    }
................................................................................
        cd [file join $srcdir win]
        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir]  {*}[my NmakeOpts] release
      } else {
        error "No make.tcl or makefile.vc found for project $name"
      }
    }
  }

  method make-install DEST {
    set PWD [pwd]
    set srcdir [my define get srcdir]
    cd $srcdir
    if {$DEST eq {}} {
      error "No destination given"
    }
................................................................................
      } else {
        puts "[self] VFS INSTALL $DEST"
        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install
      }
    }
    cd $PWD
  }

  # Detect what directory contains the Makefile template
  method MakeDir {srcdir} {
    set localsrcdir $srcdir
    if {[file exists [file join $srcdir generic]]} {
      my define add include_dir [file join $srcdir generic]
    }
    if {[file exists [file join $srcdir win]]} {
................................................................................
       my define add include_dir [file join $srcdir win]
    }
    if {[file exists [file join $srcdir makefile.vc]]} {
      set localsrcdir [file join $srcdir win]
    }
    return $localsrcdir
  }

  method NmakeOpts {} {
    set opts {}
    set builddir [file normalize [my define get builddir]]

    if {[my <project> define exists tclsrcdir]} {
      ###
      # On Windows we are probably running under MSYS, which doesn't deal with
................................................................................
        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]
................................................................................
    foreach {f v} $argdat {
      dict set cstruct $name $f $v
    }
    if {![dict exists $cstruct $name public]} {
      dict set cstruct $name public 1
    }
  }

  method include header {
    my define add include $header
  }

  method include_dir args {
    my define add include_dir {*}$args
  }
................................................................................
      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]
................................................................................
    set info [next]
    dict set info scm fossil
    foreach {field value} [::practcl::fossil_status [my define get srcdir]] {
      dict set info $field $value
    }
    return $info
  }

  # Clone the source
  method ScmClone  {} {
    set srcdir [my SrcDir]
    if {[file exists [file join $srcdir .fslckout]]} {
      return
    }
    if {[file exists [file join $srcdir _FOSSIL_]]} {

This page was generated in about 0.038s by Fossil 2.7 [c5abb962aa] 2018-09-20 13:38:44