Tcl Library Source Code

Changes On Branch scgi
Login
Core Home Blog Docs Downloads Tickets Timeline Branches Tags Wiki
Hide Diff Patch Unified Diff

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

Changes In Branch scgi Excluding Merge-Ins

This is equivalent to a diff from 2cd687d6e6 to a423fd6576

2015-05-30
00:01
rest - Tkt [87e374b7e4] - Updated/reworked documentation to be properly doctools. check-in: 2af315d3c6 user: andreask tags: trunk
2015-05-29
22:37
Re-doing the SCGI->ODIE merge check-in: b5bd71aa95 user: hypnotoad tags: odie
22:35
Added the markdown package Added a minimalist TclOO based webserver Added an example webserver that servers ASCII files from disk as well as dynamic content. SCGI now extends the minimal webserver SCGI now passes tests. The test harness works with the test script, and it will also interface with fossil running in SCGI mode. (At least enough to get a Redirect to where the query should have gone.) (Re-creating the checking in the scgi branch after checking it into odie) Closed-Leaf check-in: a423fd6576 user: hypnotoad tags: scgi
10:38
Indexing the SCGI module check-in: c906287ea7 user: hypnotoad tags: scgi
2015-05-28
05:59
Ticket [5613c718c2]. Applied patch for review, and editing. Leaf check-in: 4e2b979bcb user: aku tags: tkt-5613c718c2-cwarnings
05:40
Applied patch from ticket. New branch. Not in a state suitable for merging. See comments in the ticket, i.e. [785d2954d4]. check-in: 9aff74cefd user: aku tags: tkt-785d2954d4-jsonc
2015-05-27
21:33
Adding a new module to implement SCGI server and application functions. check-in: 693c2ee06f user: hypnotoad tags: scgi
00:46
Start fixing up the documentation of package "rest". check-in: f7c45d905d user: andreask tags: aku-87e374b7e4-rest-docs
2015-05-26
23:41
Keep up to date with trunk check-in: ca4c2acc78 user: andreask tags: huddle-a753cade83
23:06
fileutil, fileutil::traverse - Ticket [9b52204fea] - Added testcases showing the O(n**2) set of paths based on the doc example structure. Fixed that example and regenerated embedded docs. check-in: 2cd687d6e6 user: andreask tags: trunk
22:28
fileutil, fileutil::traverse - Ticket [9b52204fea] - Documented the O(n**2) issue with traversing pathologically cross-linked directory hierarchies like /sys. Updated embedded documentation. check-in: 4ae879c0ea user: andreask tags: trunk

Added examples/httpd/htdocs/example.md. 





























































































































































































































































































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

An h1 header
============

Paragraphs are separated by a blank line.

2nd paragraph. *Italic*, **bold**, and `monospace`. Itemized lists
look like:

  * this one
  * that one
  * the other one

Note that --- not considering the asterisk --- the actual text
content starts at 4-columns in.

> Block quotes are
> written like so.
>
> They can span multiple paragraphs,
> if you like.

Use 3 dashes for an em-dash. Use 2 dashes for ranges (ex., "it's all
in chapters 12--14"). Three dots ... will be converted to an ellipsis.
Unicode is supported. ☺



An h2 header
------------

Here's a numbered list:

 1. first item
 2. second item
 3. third item

Note again how the actual text starts at 4 columns in (4 characters
from the left side). Here's a code sample:

    # Let me re-iterate ...
    for i in 1 .. 10 { do-something(i) }

As you probably guessed, indented 4 spaces. By the way, instead of
indenting the block, you can use delimited blocks, if you like:

~~~
define foobar() {
    print "Welcome to flavor country!";
}
~~~

(which makes copying & pasting easier). You can optionally mark the
delimited block for Pandoc to syntax highlight it:

~~~python
import time
# Quick, count to ten!
for i in range(10):
    # (but not *too* quick)
    time.sleep(0.5)
    print i
~~~



### An h3 header ###

Now a nested list:

 1. First, get these ingredients:

      * carrots
      * celery
      * lentils

 2. Boil some water.

 3. Dump everything in the pot and follow
    this algorithm:

        find wooden spoon
        uncover pot
        stir
        cover pot
        balance wooden spoon precariously on pot handle
        wait 10 minutes
        goto first step (or shut off burner when done)

    Do not bump wooden spoon or it will fall.

Notice again how text always lines up on 4-space indents (including
that last line which continues item 3 above).

Here's a link to [a website](http://foo.bar), to a [local
doc](local-doc.html), and to a [section heading in the current
doc](#an-h2-header). Here's a footnote [^1].

[^1]: Footnote text goes here.

Tables can look like this:

size  material      color
----  ------------  ------------
9     leather       brown
10    hemp canvas   natural
11    glass         transparent

Table: Shoes, their sizes, and what they're made of

(The above is the caption for the table.) Pandoc also supports
multi-line tables:

--------  -----------------------
keyword   text
--------  -----------------------
red       Sunsets, apples, and
          other red or reddish
          things.

green     Leaves, grass, frogs
          and other things it's
          not easy being.
--------  -----------------------

A horizontal rule follows.

***

Here's a definition list:

apples
  : Good for making applesauce.
oranges
  : Citrus!
tomatoes
  : There's no "e" in tomatoe.

Again, text is indented 4 spaces. (Put a blank line between each
term/definition pair to spread things out more.)

Here's a "line block":

| Line one
|   Line too
| Line tree

and images can be specified like so:

![example image](example-image.jpg "An exemplary image")

Inline math equations go in like so: $\omega = d\phi / dt$. Display
math should get its own line and be put in in double-dollarsigns:

$$I = \int \rho R^{2} dV$$

And note that you can backslash-escape any punctuation characters
which you wish to be displayed literally, ex.: \`foo\`, \*bar\*, etc.

Added examples/httpd/htdocs/index.html. 































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

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

<html>
<head>
<title>It Works!</title>
</head>
<body>
Your webserver works!

Here are a few links to try:
<ul>
<li><a href=/dynamic>A dynamic page</a>
<li><a href=example.md>A page in markdown</a>
<li><a
</body>
</html>

Added examples/httpd/httpd.tcl. 









































































































































































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

###
# Simple webserver example
###

set DIR [file dirname [file normalize [info script]]]

set auto_path [linsert $auto_path 0 [file normalize [file join $DIR .. .. modules]]]
puts $auto_path
package require httpd

oo::class create mycontent {
  superclass ::httpd::reply

  method content {} {
    my puts "<HTML>"
    my puts "<BODY>"
    my puts "<H1>HELLO WORLD!</H1>"
    my puts "The time is now [my timestamp]"
    my puts "</BODY>"
    my puts "</HTML>"
  }
}

oo::class create myfile {
  superclass ::httpd::reply
  
  method notfound {} {
    my reset
    set code 404
    set errorstring [my meta getnull error_codes $code]
    my meta set reply_status "$code $errorstring"
    my puts "
<HTML>
<HEAD>
<TITLE>$code $errorstring</TITLE>
</HEAD>
<BODY>"
      my puts "
Got the error <b>$code $errorstring</b>
<p>
while trying to obtain $data(url)
      "
    my puts "</BODY>
</HTML>"
  }
  
  method content {} {
    set docroot [my <server> meta get doc_root]
    set path [my meta get query_header REQUEST_PATH]
    set path [string trimleft $path /]
    set filename [file join $docroot $path]
    if {![file exists $filename]} {
      my notfound
      return
    }
    switch [file extension $filename] {
      .html -
      .htm {
        my meta set reply_headers  Content-Type: {text/html; charset=ISO-8859-1}
        my puts [cat $filename]
      }
      .txt {
        my meta set reply_headers  Content-Type: {text/plain}
        my puts [cat $filename]
      }
      .md {
        my meta set reply_headers  Content-Type: {text/html; charset=ISO-8859-1}
        package require Markdown
        set dat [cat $filename]
        my puts [::Markdown::convert $dat]
      }
      default {
        my notfound
        return
      }
    }
  }
}

oo::class create myserver {
  superclass httpd::server
  
  method dispatch pageobj {
    set path [$pageobj meta getnull query_header REQUEST_PATH]
    set path [string trimleft $path /]
    if {$path in {{} index index.html index.htm}} {
      $pageobj meta set query_header REQUEST_PATH index.html
    }
    if {[lindex [split $path /] 0] eq "dynamic"} {
      $pageobj morph mycontent
    } else {
      $pageobj morph myfile
    }
    return 200
  }
}

myserver create MAIN doc_root [file join $DIR htdocs] port 10001
vwait forever

Added modules/httpd/httpd.tcl. 





















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537

###
# Author: Sean Woods, [email protected]
##
# Adapted from the "minihttpd.tcl" file distributed with Tclhttpd
#
# The working elements have been updated to operate as a TclOO object
# running with Tcl 8.6+. Global variables and hard coded tables are
# now resident with the object, allowing this server to be more easily
# embedded another program, as well as be adapted and extended to
# support the SCGI module
###

package require uri
package require oo::meta
package require nettool
package require cron

namespace eval ::url {}

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

namespace eval ::httpd {}

::oo::class create ::httpd::reply {

  property socket buffersize   32768
  property socket blocking     0
  property socket translation  {auto crlf}

  property error_codes {
    200 {Data follows}
    204 {No Content}
    302 {Found}
    304 {Not Modified}
    400 {Bad Request}
    401 {Authorization Required}
    403 {Permission denied}
    404 {Not Found}
    408 {Request Timeout}
    411 {Length Required}
    419 {Expectation Failed}
    500 {Server Internal Error}
    501 {Server Busy}
    503 {Service Unavailable}
    504 {Service Temporarily Unavailable}
    505 {Internal Server Error}
  }
  
  property env_map {
    CONTENT_LENGTH	mime,content-length
    CONTENT_TYPE	mime,content-type
    HTTP_ACCEPT		mime,accept
    HTTP_AUTHORIZATION	mime,authorization
    HTTP_FROM		mime,from
    HTTP_REFERER	mime,referer
    HTTP_USER_AGENT	mime,user-agent
    QUERY_STRING	query
    REQUEST_METHOD	proto
    HTTP_COOKIE         mime,cookie
    HTTP_FORWARDED      mime,forwarded
    HTTP_HOST           mime,host
    HTTP_PROXY_CONNECTION mime,proxy-connection
    REMOTE_USER		remote_user
    AUTH_TYPE		auth_type
    REQUEST_URI          uri
    REQUEST_PATH         url
  }
  
  property reply_status {200 OK}

  property reply_headers_default {
    Content-Type: {text/html; charset=ISO-8859-1}
    Connection: close
  }  
  property reply_headers {}

  constructor {newsock ServerObj args} {
    my variable chan
    my variable data

    array set data {
      state start
      version 0
    }

    oo::objdefine [self] forward <server> $ServerObj
    foreach {field value} [::oo::meta::args_to_options {*}$args] {
      my meta set $field $value
    }
    
    set chan $newsock
    chan configure $chan \
      -blocking [my meta get socket blocking] \
      -translation [my meta get socket translation] \
      -buffersize [my meta get socket buffersize]
    chan event $chan readable [namespace code {my RequestRead}]
  }
  
  ###
  # clean up on exit
  ###
  destructor {
    my <server> unregister [self]
    my variable chan
    catch {close $chan}
  }

  method error {code {msg {}}} {
    my reset
    my variable data
    if {![info exists data(url)]} {
      set data(url) {}
    }
    set errorstring [my meta getnull error_codes $code]
    my meta set reply_headers Content-Type: {text/html; charset=ISO-8859-1}
    my meta set reply_status "$code $errorstring"
      my puts "
<HTML>
<HEAD>
<TITLE>$code $errorstring</TITLE>
</HEAD>
<BODY>"
    if {$msg eq {}} {
      my puts "
Got the error <b>$code $errorstring</b>
<p>
while trying to obtain $data(url)
      "
    } else {
      my puts "
Guru meditation #[clock seconds]
<p>
The server encountered an internal error:
<p>
<pre>$msg</pre>
<p>
For deeper understanding:
<p>
<pre>$::errorInfo</pre>
"
    }
    my puts "</BODY>
</HTML>"
    my output
  }
  
  
  ###
  # REPLACE ME:
  # This method is the "meat" of your application.
  # It writes to the result buffer via the "puts" method
  # and can tweak the headers via "meta put header_reply"
  ###
  method content {} {
    my puts "<HTML>"
    my puts "<BODY>"
    my puts "<H1>HELLO WORLD!</H1>"
    my puts "</BODY>"
    my puts "</HTML>"
  }

  ###
  # Transform this object to another class
  ###
  method morph newclass {
    set newclass ::[string trimleft $newclass :]
    if {$newclass eq [info object class [self]]} {
      return
    }
    my MorphExit
    oo::objdefine [self] class $newclass
    my MorphEnter
  }

  ###
  # Actions to perform as the new class when
  # we morph into it
  ###
  method MorphEnter {} {
    
  }
  
  ###
  # Actions to perform as our present class
  # prior to changing to our new class
  ###
  method MorphExit {} {
    
  }

  ###
  # Output the result or error to the channel
  # and destroy this object
  ###
  method output {} {
    my variable reply_body
    set headers [my meta get reply_headers]
    set result "HTTP/1.0 [my meta get reply_status]\n"
    foreach {key value} $headers {  
      append result "$key $value" \n
    }
    append result "Content-length: [string length $reply_body]" \n \n
    append result $reply_body
    my variable chan
    puts $chan $result
    flush $chan
    my destroy
  }

  ###
  # Append to the result buffer
  ###
  method puts line {
    my variable reply_body
    append reply_body $line \n
  }

  ###
  # Read out the contents of the POST
  ###
  method query_body {} {
    my variable query_body
    return $query_body
  }

  ###
  # Read the request from the client
  # This code was adapted from the HttpdRead procedure in
  # tclhttpd
  ###
  method RequestRead {} {
    my variable chan
    my variable data

    if {[catch {gets $chan line} readCount]} {
      my <server> log "read error: $readCount"
      my destroy
      return
    }
    
    # State machine is a function of our state variable:
    #	start: the connection is new
    #	mime: we are reading the protocol headers
    # and how much was read. Note that
    # [string compare $readCount 0] maps -1 to -1, 0 to 0, and > 0 to 1
    set state [string compare $readCount 0],$data(state)
    switch -glob -- $state {
      1,start	{
        set data(proto) [lindex $line 0]
        set data(uri) [lindex $line 1]
        set data(version) [lindex [split [lindex $line end] /] end]
        if {[catch {::uri::split $data(uri)} data(uri_info)]} {
          my <server> log HttpError $line
          my destroy
          return
        }
        set data(query) [dict get $data(uri_info) query]
        set data(url) [dict get $data(uri_info) path]
        set data(state) mime
        set data(line) $line
        my <server> counter url_hits
      }
      0,start {
        # This can happen in between requests.
      }
      1,mime	{
        # This regexp picks up
        # key: value
        # MIME headers.  MIME headers may be continue with a line
        # that starts with spaces.
        if {[regexp {^([^ :]+):[ 	]*(.*)} $line dummy key value]} {  
          # The following allows something to
          # recreate the headers exactly

          lappend data(headerlist) $key $value

          # The rest of this makes it easier to pick out
          # headers from the data(mime,headername) array

          set key [string tolower $key]
          if {[info exists data(mime,$key)]} {
            append data(mime,$key) ,$value
          } else {
            set data(mime,$key) $value
            lappend data(mimeorder) $key
          }
          set data(key) $key
        } elseif {[regexp {^[ 	]+(.*)}  $line dummy value]} {
          # Are there really continuation lines in the spec?
          if {[info exists data(key)]} {
            append data(mime,$data(key)) " " $value
          } else {
            my error 400 $line
            return
          }
        } else {
          my error 400 $line
          return
        }
        ###
        # The old virtual hosts code for httpd lived here
        ###
      }
      0,mime	{
        if {$data(proto) == "POST"} {
          chan configure $chan  -translation {binary crlf}
          if {![info exists data(mime,content-length)]} {
            my error 411
            return
          }
          set data(count) $data(mime,content-length)
          if {$data(version) >= 1.1 && [info exists data(mime,expect)]} {
            if {$data(mime,expect) == "100-continue"} {
              puts $chan "100 Continue HTTP/1.1\n"
              flush $chan
            } else {
              my error 419 $data(mime,expect)
              return
            }
          }

          # Flag the need to check for an extra newline
          # in SSL connections by some browsers.

          set data(checkNewline) 1

          # Facilitate a backdoor hook between Url_DecodeQuery
          # where it will read the post data on behalf of the
          # domain handler in the case where the domain handler
          # doesn't use an Httpd call to read the post data itself.

          #Url_PostHook $chan $data(count)
        } else {
          #Url_PostHook $chan 0    ;# Clear any left-over hook
          set data(count) 0
        }
  
        # Disabling this fileevent makes it possible to use
        # http::geturl in domain handlers reliably
  
        chan event $chan readable {}
        
        ###
        # publish the bits of the data array that
        # are fit for public consumption
        ###
        foreach {field datamap} [my meta get env_map] {
          if {[info exists data($datamap)]} {
            my meta set query_headers $field $data($datamap)
          }
        }
        my meta set query_headers QUERY_STRING [dict getnull $data(uri_info) query]
        
        # Dispatch to the URL implementation.
        if [catch {
          set code [my <server> dispatch [self]]
          if {$code eq 200} {
            my content
          }
        } err] {
          my error 500 $err
        } else {
          my output
        }
        return
      }
      -1,* {
          if {[chan blocked $chan]} {
              # Blocked before getting a whole line
              return
          }
          if {[eof $chan]} {
            my destroy
            return
          }
      }
      default {
        my error 404 "$state ?? [expr {[eof $chan] ? "EOF" : ""}]"
        return
      }
    }
  }

  ###
  # Reset the result
  ###
  method reset {} {
    my variable reply_body
    my meta set reply_headers [my meta get reply_headers_default]
    my meta set reply_headers Date: [my timestamp]
    
    my variable data
    
    set reply_body {}
  }
  
  ###
  # Return true of this class as waited too long to respond
  ###
  method timedOut {} {
    return 0
  }
  
  ###
  # Return a timestamp
  ###
  method timestamp {} {
    return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
  }
}

###
# A simplistic web server, with a few caveats:
# 1) It only really understands "GET" style queries.
# 2) It is not hardened in any way against malicious attacks
# 3) By default it will only listen on localhost
###
::oo::class create ::httpd::server {
  
  property port         auto
  property myaddr       127.0.0.1
  property reply_class  ::httpd::reply

  constructor {args} {
    foreach {field value} [::oo::meta::args_to_options {*}$args] {
      my meta set $field $value
    }
    my start
  }
  
  destructor {
    my stop
  }

  method connect {sock ip port} {
    my variable open_connections
    set class [my meta get reply_class]
    set pageobj [$class new $sock [self] remote_ip $ip remote_port $port]
    lappend open_connections $pageobj
  }

  method counter which {
    my variable counters
    incr counters($which)
  }
  

  ###
  # Clean up any process that has gone out for lunch
  ###
  method CheckTimeout {} {
    my variable open_connections
    set objlist $open_connections
    foreach obj $objlist {
      if {[catch {$obj timedOut} timeout]} {
        my unregister $obj
        continue
      }
      if {$timeout} {
        catch {close [$obj chan]}
        catch {$obj destroy}
        my unregister $obj
      }
    }
  }
  
  ###
  # REPLACE ME:
  # This method should perform any transformations
  # or setup to the page object based on headers/state/etc
  # If all is well, return 200. Any other code will be interpreted
  # as an error
  ###
  method dispatch {pageobj} {
    return 200
  }

  method log args {
    # Do nothing for now
  }
  
  method register object {
    my variable open_connections
    if { $object ni $open_connections } {
      lappend open_connections $object
    }
  }
  
  method unregister object {
    my variable open_connections
    ldelete open_connections $object
  }
  
  method start {} {
    my variable socklist open_connections
    set open_connections {}
    set port [my meta getnull port]
    if { $port in {auto {}} } {
      set port [::nettool::allocate_port 8015]
      my meta set port $port
    }
    my meta set port_listening $port
    set myaddr [my meta get myaddr]
    if {$myaddr ne {}} {
      foreach ip $myaddr {
        lappend socklist [socket -server [namespace code [list my connect]] -myaddr $ip $port]
      }
    } else {
      lappend socklist [socket -server [namespace code [list my connect]] $port]
    }
    ::cron::every [self] 120 [namespace code {my CheckTimeout}]
  }

  method stop {} {
    my variable socklist
    foreach sock $socklist {
      catch {close $sock}
    }
    set socklist {}
    ::cron::cancel [self]
  }
}

package provide httpd 0.1

Added modules/httpd/httpd.test. 











































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

# httpd.test - Copyright (c) 2015 Sean Woods

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

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2

testsNeed TclOO 1

support {
  use ooutil/oometa.tcl oo::meta
  use ncgi/ncgi.tcl ncgi
  use httpd/httpd.tcl httpd
}

testing {
  useLocal httpd.tcl httpd
}

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


httpd::server create TESTAPP port 10001
vwait forever
# -------------------------------------------------------------------------

testsuiteCleanup

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

Added modules/httpd/pkgIndex.tcl. 



















>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8

#checker -scope global exclude warnUndefinedVar
# var in question is 'dir'.
if {![package vsatisfies [package provide Tcl] 8.5]} {
    # PRAGMA: returnok
    return
}
package ifneeded httpd 0.1 [list source [file join $dir httpd.tcl]]

Added modules/markdown/markdown.tcl. 









































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































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

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

#
# The MIT License (MIT)
#
# Copyright (c) 2014 Caius Project
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
# THE SOFTWARE.
#

package require textutil

## \file
# \brief Functions for converting markdown to HTML.

##
# \brief Functions for converting markdown to HTML.
#
namespace eval Markdown {

    namespace export convert

    ##
    #
    # Converts text written in markdown to HTML.
    #
    # @param markdown  currently takes as a single argument the text in markdown
    #
    # The output of this function is only a fragment, not a complete HTML
    # document. The format of the output is generic XHTML.
    #
    proc convert {markdown} {
        set markdown [regsub {\r\n?} $markdown {\n}]
        set markdown [::textutil::untabify2 $markdown 4]
        set markdown [string trimright $markdown]

        # COLLECT REFERENCES
        array unset ::Markdown::_references
        array set ::Markdown::_references [collect_references markdown]

        # PROCESS
        return [apply_templates markdown]
    }

    ## \private
    proc collect_references {markdown_var} {
        upvar $markdown_var markdown

        set lines [split $markdown \n]
        set no_lines [llength $lines]
        set index 0

        array set references {}

        while {$index < $no_lines} {
            set line [lindex $lines $index]

            if {[regexp \
                {^[ ]{0,3}\[((?:[^\]]|\[[^\]]*?\])+)\]:\s*(\S+)(?:\s+(([\"\']).*\4|\(.*\))\s*$)?} \
                $line match ref link title]} \
            {
                set title [string trim [string range $title 1 end-1]]
                if {$title eq {}} {
                    set next_line [lindex $lines [expr $index + 1]]

                    if {[regexp \
                        {^(?:\s+(?:([\"\']).*\1|\(.*\))\s*$)} \
                        $next_line]} \
                    {
                        set title [string range [string trim $next_line] 1 end-1]
                        incr index
                    }
                }
                set ref [string tolower $ref]
                set link [string trim $link {<>}]
                set references($ref) [list $link $title]
            }

            incr index
        }

        return [array get references]
    }

    ## \private
    proc apply_templates {markdown_var {parent {}}} {
        upvar $markdown_var markdown

        set lines    [split $markdown \n]
        set no_lines [llength $lines]
        set index    0
        set result   {}

        set ul_match {^[ ]{0,3}(?:\*(?!\s*\*\s*\*\s*$)|-(?!\s*-\s*-\s*$)|\+) }
        set ol_match {^[ ]{0,3}\d+\. }

        # PROCESS MARKDOWN
        while {$index < $no_lines} {
            set line [lindex $lines $index]

            switch -regexp $line {
                {^\s*$} {
                    # EMPTY LINES
                    if {![regexp {^\s*$} [lindex $lines [expr $index - 1]]]} {
                        append result "\n\n"
                    }
                    incr index
                }
                {^[ ]{0,3}\[(?:[^\]]|\[[^\]]*?\])+\]:\s*\S+(?:\s+(?:([\"\']).*\1|\(.*\))\s*$)?} {
                    # SKIP REFERENCES
                    set next_line [lindex $lines [expr $index + 1]]

                    if {[regexp \
                        {^(?:\s+(?:([\"\']).*\1|\(.*\))\s*$)} \
                        $next_line]} \
                    {
                        incr index
                    }

                    incr index
                }
                {^[ ]{0,3}-[ ]*-[ ]*-[- ]*$} -
                {^[ ]{0,3}_[ ]*_[ ]*_[_ ]*$} -
                {^[ ]{0,3}\*[ ]*\*[ ]*\*[\* ]*$} {
                    # HORIZONTAL RULES
                    append result "<hr/>"
                    incr index
                }
                {^[ ]{0,3}#{1,6}} {
                    # ATX STYLE HEADINGS
                    set h_level 0
                    set h_result {}

                    while {$index < $no_lines && ![is_empty_line $line]} {
                        incr index

                        if {!$h_level} {
                            regexp {^\s*#+} $line m
                            set h_level [string length [string trim $m]]
                        }

                        lappend h_result $line

                        set line [lindex $lines $index]
                    }

                    set h_result [\
                        parse_inline [\
                            regsub -all {^\s*#+\s*|\s*#+\s*$} [join $h_result \n] {} \
                        ]\
                    ]

                    append result "<h$h_level>$h_result</h$h_level>"
                }
                {^[ ]{0,3}\>} {
                    # BLOCK QUOTES
                    set bq_result {}

                    while {$index < $no_lines} {
                        incr index

                        lappend bq_result [regsub {^[ ]{0,3}\>[ ]?} $line {}]

                        if {[is_empty_line [lindex $lines $index]]} {
                            set eoq 0

                            for {set peek $index} {$peek < $no_lines} {incr peek} {
                                set line [lindex $lines $peek]

                                if {![is_empty_line $line]} {
                                    if {![regexp {^[ ]{0,3}\>} $line]} {
                                        set eoq 1
                                    }
                                    break
                                }
                            }

                            if {$eoq} { break }
                        }

                        set line [lindex $lines $index]
                    }
                    set bq_result [string trim [join $bq_result \n]]

                    append result <blockquote>\n \
                                    [apply_templates bq_result] \
                                  \n</blockquote>
                }
                {^\s{4,}\S+} {
                    # CODE BLOCKS
                    set code_result {}

                    while {$index < $no_lines} {
                        incr index

                        lappend code_result [html_escape [\
                            regsub {^    } $line {}]\
                        ]

                        set eoc 0
                        for {set peek $index} {$peek < $no_lines} {incr peek} {
                            set line [lindex $lines $peek]

                            if {![is_empty_line $line]} {
                                if {![regexp {^\s{4,}} $line]} {
                                    set eoc 1
                                }
                                break
                            }
                        }

                        if {$eoc} { break }

                        set line [lindex $lines $index]
                    }
                    set code_result [join $code_result \n]

                    append result <pre><code> $code_result \n </code></pre>
                }
                {^(?:(?:`{3,})|(?:~{3,}))(?:\{?\S+\}?)?\s*$} {
                    # FENCED CODE BLOCKS
                    set code_result {}

                    if {[string index $line 0] eq {`}} {
                        set end_match {^`{3,}\s*$}
                    } else {
                        set end_match {^~{3,}\s*$}
                    }

                    while {$index < $no_lines} {
                        incr index

                        set line [lindex $lines $index]

                        if {[regexp $end_match $line]} {
                            incr index
                            break
                        }

                        lappend code_result [html_escape $line]
                    }
                    set code_result [join $code_result \n]

                    append result <pre><code> $code_result </code></pre>
                }
                {^[ ]{0,3}(?:\*|-|\+) |^[ ]{0,3}\d+\. } {
                    # LISTS
                    set list_result {}

                    # continue matching same list type
                    if {[regexp $ol_match $line]} {
                        set list_type ol
                        set list_match $ol_match
                    } else {
                        set list_type ul
                        set list_match $ul_match
                    }

                    set last_line AAA

                    while {$index < $no_lines} \
                    {
                        if {![regexp $list_match [lindex $lines $index]]} {
                            break
                        }

                        set item_result {}
                        set in_p 1
                        set p_count 1

                        if {[is_empty_line $last_line]} {
                            incr p_count
                        }

                        set last_line $line
                        set line [regsub "$list_match\\s*" $line {}]

                        # prevent recursion on same line
                        set line [regsub {\A(\d+)\.(\s+)}   $line {\1\\.\2}]
                        set line [regsub {\A(\*|\+|-)(\s+)} $line {\\\1\2}]

                        lappend item_result $line

                        for {set peek [expr $index + 1]} {$peek < $no_lines} {incr peek} {
                            set line [lindex $lines $peek]

                            if {[is_empty_line $line]} {
                                set in_p 0
                            }\
                            elseif {[regexp {^    } $line]} {
                                if {!$in_p} {
                                    incr p_count
                                }
                                set in_p 1
                            }\
                            elseif {[regexp $list_match $line]} {
                                if {!$in_p} {
                                    incr p_count
                                }
                                break
                            }\
                            elseif {!$in_p} {
                                break
                            }

                            set last_line $line
                            lappend item_result [regsub {^    } $line {}]
                        }

                        set item_result [join $item_result \n]

                        if {$p_count > 1} {
                            set item_result [apply_templates item_result li]
                        } else {
                            if {[regexp -lineanchor \
                                {(\A.*?)((?:^[ ]{0,3}(?:\*|-|\+) |^[ ]{0,3}\d+\. ).*\Z)} \
                                $item_result \
                                match para rest]} \
                            {
                                set item_result [parse_inline $para]
                                append item_result [apply_templates rest]
                            } else {
                                set item_result [parse_inline $item_result]
                            }
                        }

                        lappend list_result "<li>$item_result</li>"
                        set index $peek
                    }

                    append result <$list_type>\n \
                                    [join $list_result \n] \
                                </$list_type>\n\n
                }
                {^<(?:p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math|ins|del)} {
                    # HTML BLOCKS
                    set re_htmltag {<(/?)(\w+)(?:\s+\w+=(?:\"[^\"]+\"|'[^']+'))*\s*>}
                    set buffer {}

                    while {$index < $no_lines} \
                    {
                        while {$index < $no_lines} \
                        {
                            incr index

                            append buffer $line \n

                            if {[is_empty_line $line]} {
                                break
                            }

                            set line [lindex $lines $index]
                        }

                        set tags [regexp -inline -all $re_htmltag  $buffer]
                        set stack_count 0

                        foreach {match type name} $tags {
                            if {$type eq {}} {
                                incr stack_count +1
                            } else {
                                incr stack_count -1
                            }
                        }

                        if {$stack_count == 0} { break }
                    }

                    append result $buffer
                }
                {(?:^\s{0,3}|[^\\]+)\|} {
                    # SIMPLE TABLES
                    set cell_align {}
                    set row_count 0

                    while {$index < $no_lines} \
                    {
                        # insert a space between || to handle empty cells
                        set row_cols [regexp -inline -all {(?:[^|]|\\\|)+} \
                            [regsub -all {\|(?=\|)} [string trim $line] {| }] \
                        ]

                        if {$row_count == 0} \
                        {
                            set sep_cols [lindex $lines [expr $index + 1]]

                            # check if we have a separator row
                            if {[regexp {^\s{0,3}\|?(?:\s*:?-+:?(?:\s*$|\s*\|))+} $sep_cols]} \
                            {
                                set sep_cols [regexp -inline -all {(?:[^|]|\\\|)+} \
                                    [string trim $sep_cols]]

                                foreach {cell_data} $sep_cols \
                                {
                                    switch -regexp $cell_data {
                                        {:-*:} {
                                            lappend cell_align center
                                        }
                                        {:-+} {
                                            lappend cell_align left
                                        }
                                        {-+:} {
                                            lappend cell_align right
                                        }
                                        default {
                                            lappend cell_align {}
                                        }
                                    }
                                }

                                incr index
                            }

                            append result "<table class=\"table\">\n"
                            append result "<thead>\n"
                            append result "  <tr>\n"

                            if {$cell_align ne {}} {
                                set num_cols [llength $cell_align]
                            } else {
                                set num_cols [llength $row_cols]
                            }

                            for {set i 0} {$i < $num_cols} {incr i} \
                            {
                                if {[set align [lindex $cell_align $i]] ne {}} {
                                    append result "    <th style=\"text-align: $align\">"
                                } else {
                                    append result "    <th>"
                                }

                                append result [parse_inline [string trim \
                                    [lindex $row_cols $i]]] </th> "\n"
                            }

                            append result "  </tr>\n"
                            append result "</thead>\n"
                        } else {
                            if {$row_count == 1} {
                                append result "<tbody>\n"
                            }

                            append result "  <tr>\n"

                            if {$cell_align ne {}} {
                                set num_cols [llength $cell_align]
                            } else {
                                set num_cols [llength $row_cols]
                            }

                            for {set i 0} {$i < $num_cols} {incr i} \
                            {
                                if {[set align [lindex $cell_align $i]] ne {}} {
                                    append result "    <td style=\"text-align: $align\">"
                                } else {
                                    append result "    <td>"
                                }

                                append result [parse_inline [string trim \
                                    [lindex $row_cols $i]]] </td> "\n"
                            }

                            append result "  </tr>\n"
                        }

                        incr row_count

                        set line [lindex $lines [incr index]]

                        if {![regexp {(?:^\s{0,3}|[^\\]+)\|} $line]} {
                            switch $row_count {
                                1 {
                                    append result "</table>\n"
                                }
                                default {
                                    append result "</tbody>\n"
                                    append result "</table>\n"
                                }
                            }

                            break
                        }
                    }
                }
                default {
                    # PARAGRAPHS AND SETTEXT STYLE HEADERS
                    set p_type p
                    set p_result {}

                    while {($index < $no_lines) && ![is_empty_line $line]} \
                    {
                        incr index

                        switch -regexp $line {
                            {^[ ]{0,3}=+$} {
                                set p_type h1
                                break
                            }
                            {^[ ]{0,3}-+$} {
                                set p_type h2
                                break
                            }
                            {^[ ]{0,3}(?:\*|-|\+) |^[ ]{0,3}\d+\. } {
                                if {$parent eq {li}} {
                                    incr index -1
                                    break
                                } else {
                                    lappend p_result $line
                                }
                            }
                            {^[ ]{0,3}-[ ]*-[ ]*-[- ]*$} -
                            {^[ ]{0,3}_[ ]*_[ ]*_[_ ]*$} -
                            {^[ ]{0,3}\*[ ]*\*[ ]*\*[\* ]*$} -
                            {^[ ]{0,3}#{1,6}} \
                            {
                                incr index -1
                                break
                            }
                            default {
                                lappend p_result $line
                            }
                        }

                        set line [lindex $lines $index]
                    }

                    set p_result [\
                        parse_inline [\
                            string trim [join $p_result \n]\
                        ]\
                    ]

                    if {[is_empty_line [regsub -all {<!--.*?-->} $p_result {}]]} {
                        # Do not make a new paragraph for just comments.
                        append result $p_result
                    } else {
                        append result "<$p_type>$p_result</$p_type>"
                    }
                }
            }
        }

        return $result
    }

    ## \private
    proc parse_inline {text} {
        set text [regsub -all -lineanchor {[ ]{2,}$} $text <br/>]

        set index 0
        set result {}

        set re_backticks   {\A`+}
        set re_whitespace  {\s}
        set re_inlinelink  {\A\!?\[((?:[^\]]|\[[^\]]*?\])+)\]\s*\(\s*((?:[^\s\)]+|\([^\s\)]+\))+)?(\s+([\"'])(.*)?\4)?\s*\)}
        set re_reflink     {\A\!?\[((?:[^\]]|\[[^\]]*?\])+)\](?:\s*\[((?:[^\]]|\[[^\]]*?\])*)\])?}
        set re_htmltag     {\A</?\w+\s*>|\A<\w+(?:\s+\w+=(?:\"[^\"]+\"|\'[^\']+\'))*\s*/?>}
        set re_autolink    {\A<(?:(\S+@\S+)|(\S+://\S+))>}
        set re_comment     {\A<!--.*?-->}
        set re_entity      {\A\&\S+;}

        while {[set chr [string index $text $index]] ne {}} {
            switch $chr {
                "\\" {
                    # ESCAPES
                    set next_chr [string index $text [expr $index + 1]]

                    if {[string first $next_chr {\`*_\{\}[]()#+-.!>|}] != -1} {
                        set chr $next_chr
                        incr index
                    }
                }
                {_} -
                {*} {
                    # EMPHASIS
                    if {[regexp $re_whitespace [string index $result end]] &&
                        [regexp $re_whitespace [string index $text [expr $index + 1]]]} \
                    {
                        #do nothing
                    } \
                    elseif {[regexp -start $index \
                        "\\A(\\$chr{1,3})((?:\[^\\$chr\\\\]|\\\\\\$chr)*)\\1" \
                        $text m del sub]} \
                    {
                        switch [string length $del] {
                            1 {
                                append result "<em>[parse_inline $sub]</em>"
                            }
                            2 {
                                append result "<strong>[parse_inline $sub]</strong>"
                            }
                            3 {
                                append result "<strong><em>[parse_inline $sub]</em></strong>"
                            }
                        }

                        incr index [string length $m]
                        continue
                    }
                }
                {`} {
                    # CODE
                    regexp -start $index $re_backticks $text m
                    set start [expr $index + [string length $m]]

                    if {[regexp -start $start -indices $m $text m]} {
                        set stop [expr [lindex $m 0] - 1]

                        set sub [string trim [string range $text $start $stop]]

                        append result "<code>[html_escape $sub]</code>"
                        set index [expr [lindex $m 1] + 1]
                        continue
                    }
                }
                {!} -
                {[} {
                    # LINKS AND IMAGES
                    if {$chr eq {!}} {
                        set ref_type img
                    } else {
                        set ref_type link
                    }

                    set match_found 0

                    if {[regexp -start $index $re_inlinelink $text m txt url ign del title]} {
                        # INLINE
                        incr index [string length $m]

                        set url [html_escape [string trim $url {<> }]]
                        set txt [parse_inline $txt]
                        set title [parse_inline $title]

                        set match_found 1
                    } elseif {[regexp -start $index $re_reflink $text m txt lbl]} {
                        if {$lbl eq {}} {
                            set lbl [regsub -all {\s+} $txt { }]
                        }

                        set lbl [string tolower $lbl]

                        if {[info exists ::Markdown::_references($lbl)]} {
                            lassign $::Markdown::_references($lbl) url title

                            set url [html_escape [string trim $url {<> }]]
                            set txt [parse_inline $txt]
                            set title [parse_inline $title]

                            # REFERENCED
                            incr index [string length $m]
                            set match_found 1
                        }
                    }

                    # PRINT IMG, A TAG
                    if {$match_found} {
                        if {$ref_type eq {link}} {
                            if {$title ne {}} {
                                append result "<a href=\"$url\" title=\"$title\">$txt</a>"
                            } else {
                                append result "<a href=\"$url\">$txt</a>"
                            }
                        } else {
                            if {$title ne {}} {
                                append result "<img src=\"$url\" alt=\"$txt\" title=\"$title\"/>"
                            } else {
                                append result "<img src=\"$url\" alt=\"$txt\"/>"
                            }
                        }

                        continue
                    }
                }
                {<} {
                    # HTML TAGS, COMMENTS AND AUTOLINKS
                    if {[regexp -start $index $re_comment $text m]} {
                        append result $m
                        incr index [string length $m]
                        continue
                    } elseif {[regexp -start $index $re_autolink $text m email link]} {
                        if {$link ne {}} {
                            set link [html_escape $link]
                            append result "<a href=\"$link\">$link</a>"
                        } else {
                            set mailto_prefix "mailto:"
                            if {![regexp "^${mailto_prefix}(.*)" $email mailto email]} {
                                # $email does not contain the prefix "mailto:".
                                set mailto "mailto:$email"
                            }
                            append result "<a href=\"$mailto\">$email</a>"
                        }
                        incr index [string length $m]
                        continue
                    } elseif {[regexp -start $index $re_htmltag $text m]} {
                        append result $m
                        incr index [string length $m]
                        continue
                    }

                    set chr [html_escape $chr]
                }
                {&} {
                    # ENTITIES
                    if {[regexp -start $index $re_entity $text m]} {
                        append result $m
                        incr index [string length $m]
                        continue
                    }

                    set chr [html_escape $chr]
                }
                {>} -
                {'} -
                "\"" {
                    # OTHER SPECIAL CHARACTERS
                    set chr [html_escape $chr]
                }
                default {}
            }

            append result $chr
            incr index
        }

        return $result
    }

    ## \private
    proc is_empty_line {line} {
        return [regexp {^\s*$} $line]
    }

    ## \private
    proc html_escape {text} {
        return [string map {& &amp; < &lt; > &gt; \" &quot;} $text]
    }
}

package provide Markdown 1.0

Added modules/markdown/pkgIndex.tcl. 

























>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# 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.

package ifneeded Markdown 1.0 [list source [file join $dir markdown.tcl]]

Added modules/ooutil/oometa.tcl. 













































































































































































































































































































































































































































































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

###
# Author: Sean Woods, [email protected]
##
# TclOO routines to implement property tracking by class and object
###
package require oo::util

namespace eval ::oo::meta {
  variable dirty_classes {}
}

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

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

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

proc ::oo::meta::ancestors class {
  set thisresult {}
  set result {}
  set queue $class
  while {[llength $queue]} {
    set tqueue $queue
    set queue {}
    foreach qclass $tqueue {
      foreach aclass [::info class superclasses $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }
      foreach aclass [::info class mixins $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }            
    }
    foreach item $tqueue {
      if { $item ni $result } {
        set result [linsert $result 0 $item]
      }
    }
  }
  return $result
}

proc ::oo::meta::info {class submethod args} {
  switch $submethod {
    rebuild {
      if {$class ni $::oo::meta::dirty_classes} {
        lappend ::oo::meta::dirty_classes $class
      }
    }
    is {
      set info [properties $class]
      return [string is [lindex $args 0] -strict [dict getnull $info {*}[lrange $args 1 end]]]
    }
    for -
    map {
      set info [properties $class]
      puts [list [dict get $info {*}[lrange $args 1 end-1]]]
      return [uplevel 1 [list ::dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]]
    }
    with {
      upvar 1 TEMPVAR info
      set info [properties $class]
      return [uplevel 1 [list ::dict with TEMPVAR {*}$args]]
    }
    append -
    incr -
    lappend -
    set -
    unset -
    update {
      if {$class ni $::oo::meta::dirty_classes} {
        lappend ::oo::meta::dirty_classes $class
      }
      ::dict $submethod ::oo::meta::local_property($class) {*}$args
    }
    dump {
      set info [properties $class]
      return $info
    }
    default {
      set info [properties $class]
      return [::dict $submethod $info {*}$args] 
    }
  }
}

proc ::oo::meta::properties class {
  ###
  # Destroy the cache of all derivitive classes
  ###
  variable dirty_classes
  foreach dclass $dirty_classes {
    foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
      if {$dclass in $cancestors} {
        unset -nocomplain ::oo::meta::cached_property($cclass)
        unset -nocomplain ::oo::meta::cached_hierarchy($cclass)
      }
    }
  }

  ###
  # If the cache is available, use it
  ###
  variable cached_property
  if {[::info exists cached_property($class)]} {
    return $cached_property($class)
  }
  ###
  # Build a cache of the hierarchy and the
  # aggregate properties for this class and store
  # them for future use
  ###
  variable cached_hierarchy
  set properties {}
  set stack {}
  variable local_property
  set cached_hierarchy($class) [::oo::meta::ancestors $class]
  foreach aclass $cached_hierarchy($class) {
    if {[::info exists local_property($aclass)]} {
      lappend stack $local_property($aclass)
    }
  }
  if {[llength $stack]} {
    set properties [dict merge {*}$stack]
  } else {
    set properties {}
  }
  set cached_property($class) $properties
  return $properties
}

###
# Add properties and option handling
###
proc ::oo::define::property {args} {
  set class [lindex [::info level -1] 1]
  ::oo::meta::info $class set {*}$args
}

oo::define oo::class {

  method meta {submethod args} {
    set class [self]
    switch $submethod {
      is {
        set info [::oo::meta::properties $class]
        return [string is [lindex $args 0] -strict [dict getnull $info {*}[lrange $args 1 end]]]
      }
      for -
      map {
        set info [::oo::meta::properties $class]
        return [uplevel 1 [list dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]]
      }
      with {
        upvar 1 TEMPVAR info
        set info [::oo::meta::properties $class]
        return [uplevel 1 [list dict with TEMPVAR {*}$args]]
      }
      dump {
        return [::oo::meta::properties $class]
      }
      append -
      incr -
      lappend -
      set -
      unset -
      update {
        ::oo::meta::info $class rebuild
        return [dict $submethod config {*}$args]
      }
      default {
        set info [::oo::meta::properties $class]
        return [dict $submethod $info {*}$args] 
      }
    }
  }
  
}

oo::define oo::object {
    
  method meta {submethod args} {
    my variable config
    if {![::info exists config]} {
      set config {}
    }
    set class [::info object class [self object]]
    switch $submethod {
      is {
        set info [dict merge [::oo::meta::properties $class] $config]
        return [string is [lindex $args 0] -strict [dict getnull $info {*}[lrange $args 1 end]]]
      }
      for -
      map {
        set info [dict merge [::oo::meta::properties $class] $config]
        return [uplevel 1 [list dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]]
      }
      with {
        upvar 1 TEMPVAR info
        set info [dict merge [::oo::meta::properties $class] $config]
        return [uplevel 1 [list dict with TEMPVAR {*}$args]]
      }
      dump {
        return [dict merge [::oo::meta::properties $class] $config]
      }
      append -
      incr -
      lappend -
      set -
      unset -
      update {
        return [dict $submethod config {*}$args]
      }
      default {
        set info [dict merge [::oo::meta::properties $class] $config]
        return [dict $submethod $info {*}$args] 
      }
    }
  }
}

package provide oo::meta 0.1

Added modules/ooutil/oooption.tcl. 

















































































































































































































































































































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

###
# Option handling for TclOO
###
package require oo::meta

oo::define oo::object {
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method InitializePublic {} {
    my variable config
    if {![info exists config]} {
      set config {}
    }
    set dat [my meta getnull option]
    foreach {var info} $dat {
      if {[dict exists $info set-command]} {
        if {[catch {my cget $var} value]} {
          dict set config $var [my cget $var default]
        } else {
          if { $value eq {} } {
            dict set config $var [my cget $var default]
          }
        }
      }
      if {![dict exists $config $var]} {
        dict set config $var [my cget $var default]
      }
    }
    foreach {var info} [my meta getnull variable] {
      if { $var eq "config" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default]} {
          set $var [dict get $info default]
        } else {
          set $var {}
        }
      }
    }
    foreach {var info} [my meta getnull array] {
      if { $var eq "config" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default]} {
          array set $var [dict get $info default]
        } else {
          array set $var {}
        }
      }
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget {field {default {}}} {
    my variable config
    set field [string trimleft $field -]
    set dat [my meta getnull option]
  
    if {[my meta is true options_strict] && ![dict exists $dat $field]} {
      error "Invalid option -$field. Valid: [dict keys $dat]"
    }
    set info [dict getnull $dat $field]    
    if {$default eq "default"} {
      set getcmd [dict getnull $info default-command]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        return [dict getnull $info default]
      }
    }
    if {[dict exists $dat $field]} {
      set getcmd [dict getnull $info get-command]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      }
      if {![dict exists $config $field]} {
        set getcmd [dict getnull $info default-command]
        if {$getcmd ne {}} {
          dict set config $field [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
        } else {
          dict set config $field [dict getnull $info default]
        }
      }
      if {$default eq "varname"} {
        set varname [my varname visconfig]
        set ${varname}($field) [dict get $config $field]
        return "${varname}($field)"
      }
      return [dict get $config $field]
    }
    if {[dict exists $config $field]} {
      return [dict get $config $field]
    }
    return [my meta get $field]
  }
  
  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"
    set dictargs [::oo::meta::args_to_options {*}$args]
    if {[llength $dictargs] == 1} {
      return [my cget [lindex $dictargs 0]]
    }
    my configurelist $dictargs
    my configurelist_triggers $dictargs
  }

  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method configurelist dictargs {
    my variable config
    set dat [my meta getnull option]
    if {[my meta is true options_strict]} {
      foreach {field val} $dictargs {
        if {![dict exists $dat $field]} {
          error "Invalid option $field. Valid: [dict keys $dat]"
        }
      }
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      dict set config $field $val
    }
  }

  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method configurelist_triggers dictargs {
    set dat [my meta getnull option]
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
}
package provide oo::option 0.1

Changes to modules/ooutil/ooutil.test.

︙︙
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


testsNeedTcl     8.5
testsNeedTcltest 2

testsNeed TclOO 1

testing {
    useLocal ooutil.tcl oo::util


}

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

test ooutil-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
    oo::class create animal {}
    namespace eval ::ooutiltest {
	oo::class create pet { superclass animal }
    }
} -body {
    namespace eval ::ooutiltest {
	oo::class create dog { superclass pet }
    }
} -cleanup {
    namespace delete ooutiltest
    rename animal {}
} -result {::ooutiltest::dog}




















































































































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


testsuiteCleanup

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








|
>
>


















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

>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159


testsNeedTcl     8.5
testsNeedTcltest 2

testsNeed TclOO 1

testing {
  useLocal ooutil.tcl oo::util
  useLocal oometa.tcl oo::meta
  useLocal oooption.tcl oo::option
}

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

test ooutil-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
    oo::class create animal {}
    namespace eval ::ooutiltest {
	oo::class create pet { superclass animal }
    }
} -body {
    namespace eval ::ooutiltest {
	oo::class create dog { superclass pet }
    }
} -cleanup {
    namespace delete ooutiltest
    rename animal {}
} -result {::ooutiltest::dog}

# Test properties

oo::class create foo {
  property color blue
  
  constructor args {
    my InitializePublic
    my configure {*}$args
  }
}

oo::class create bar {
  superclass ::foo
  property shape oval
  property option color {
    default green
  }
}

test oo-class-meta-001 {Test accessing properties} {
  foo meta get color
} blue

test oo-class-meta-002 {Test accessing properties} {
  bar meta get color
} blue

test oo-class-meta-003 {Test accessing properties} {
  bar meta get shape
} oval

bar create cheers -color pink
test oo-object-meta-001 {Test accessing properties} {
  cheers meta get color
} pink

test  oo-object-meta-002 {Test accessing properties} {
  cheers meta get shape
} oval

test  oo-object-meta-003 {Test accessing properties} {
  cheers cget color
} pink

bar create moes
test  oo-object-meta-004 {Test accessing properties} {
  moes meta get color
} green

test  oo-object-meta-005 {Test accessing properties} {
  moes meta get shape
} oval

test  oo-object-meta-006 {Test accessing properties} {
  moes cget color
} green

test  oo-object-meta-007 {Test the CGET retrieves a property if an option doesn't exist} {
  moes cget shape
} oval

###
# Test altering a property
###

oo::define ::foo property woozle whoop

test oo-modclass-meta-001 {Test accessing properties of an altered class} {
  foo meta get woozle
} whoop

test oo-modclass-meta-002 {Test accessing properties of the descendent of an altered class} {
  bar meta get woozle
} whoop

test oo-modobject-meta-001 {Test the accessing of properties of an instance of an altered class} {
  moes meta get woozle
} whoop

test obj-meta-for-001 {Test object meta for} {
  set result {}
  moes meta for {key value} option {
    lappend result $key $value
  }
  set result
} {color {
    default green
  }}

test obj-meta-with-001 {Test object meta with} {
  set result {}
  moes meta with option {}
  set color
} {
    default green
  }

test obj-meta-for-001 {Test class meta for} {
  set result {}
  bar meta for {key value} option {
    lappend result $key $value
  }
  set result
} {color {
    default green
  }}

test obj-meta-with-001 {Test class meta with} {
  set result {}
  bar meta with option {}
  set color
} {
    default green
  }

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


testsuiteCleanup

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

Changes to modules/ooutil/pkgIndex.tcl. 

1
2
3
4
5
6
7



#checker -scope global exclude warnUndefinedVar
# var in question is 'dir'.
if {![package vsatisfies [package provide Tcl] 8.5]} {
    # PRAGMA: returnok
    return
}
package ifneeded oo::util 1.2.1 [list source [file join $dir ooutil.tcl]]










>
>

1
2
3
4
5
6
7
8
9

#checker -scope global exclude warnUndefinedVar
# var in question is 'dir'.
if {![package vsatisfies [package provide Tcl] 8.5]} {
    # PRAGMA: returnok
    return
}
package ifneeded oo::util 1.2.1 [list source [file join $dir ooutil.tcl]]
package ifneeded oo::meta 0.1 [list source [file join $dir oometa.tcl]]
package ifneeded oo::option 0.1 [list source [file join $dir oooption.tcl]]

Added modules/scgi/pkgIndex.tcl. 



























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

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

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# 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.

package ifneeded scgi::app 0.1 [list source [file join $dir scgi-application.tcl]]
package ifneeded scgi::server 0.1 [list source [file join $dir scgi-server.tcl]]

Added modules/scgi/scgi-app.man.

Added modules/scgi/scgi-app.tcl. 

















































































































































































































































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

###
# Author: Sean Woods, [email protected]
###
# This file provides the "application" side of the SCGI protocol
###

package require html
package require TclOO
package require oo::meta

namespace eval ::scgi {}

proc ::scgi::decode_headers {rawheaders} {
  #
  # Take the tokenized header data and place the usual CGI headers into $env,
  # and transform the HTTP_ variables to their original HTTP header field names
  # as best as possible.
  #
  foreach {name value} $rawheaders {
    if {[regexp {^HTTP_(.*)$} $name {} nameSuffix]} {
      set nameParts [list]
      foreach namePart [split $nameSuffix _] {
        lappend nameParts [string toupper [string tolower $namePart] 0 0]
      }
      dict set headers [join $nameParts -] $value
    } else {
      dict set env $name $value
    }
  }

  #
  # Store CONTENT_LENGTH as an HTTP header named Content-Length, too.
  #
  set contentLength [dict get $env CONTENT_LENGTH]

  if {$contentLength > 0} {
    dict set headers Content-Length $contentLength
  }
  return [list env $enc headers $headers]
}

oo::class create ::scgi::reply {  
  superclass ::httpd::reply
  
  property socket buffersize   32768
  property socket blocking     0
  property socket translation  {binary binary}


  method RequestRead {} {    
    my variable chan
    my variable data
    my variable inbuffer
    set rawdata [read $chan]
    append inbuffer $rawdata
    if {[eof $chan]} {
      my destroy
      return
    }
    if {$data(state) == "start"} {
      set colonIdx [string first : $inbuffer]
      if {$colonIdx == -1} {
        # we don't have the headers length yet
        return
      } else {
        set length [string range $inbuffer 0 $colonIdx-1]
        set inbuffer [string range $inbuffer $colonIdx+1 end]
        set data(state) headers
        set data(length) $length
      }
    }
    if {$data(state) == "headers" } {
      if {[string length $inbuffer] < $data(length)+1} {
        # we don't have the complete headers yet, wait for more
        return
      }
      set headers [string range $inbuffer 0 $data(length)-1]
      set headers [lrange [split $headers \0] 0 end-1]
      my variable query_body
      set inbuffer [string range $inbuffer $data(length)+1 end]
      set data(content_length) [dict get $headers CONTENT_LENGTH]
      my meta set query_headers $headers
      set data(state) body
    }
    
    if {[string length $inbuffer] < $data(content_length)} {
      return
    }
    my variable query_body
    set query_body $inbuffer

    # Dispatch to the URL implementation.
    if [catch {
      set code [my <server> dispatch [self]]
      if {$code eq 200} {
        my content
      }
    } err] {
      my error 500 $err
    } else {
      my output
    }
    return
    
  }
  
  ###
  # Output the result or error to the channel
  # and destroy this object
  ###
  method output {} {
    my variable reply_body
    set reply_body [string trim $reply_body]
    set headers [my meta get reply_headers]
    set result "Status: [my meta get reply_status]\n"
    foreach {key value} $headers {  
      append result "$key $value" \n
    }
    append result "Content-length: [string length $reply_body]" \n \n
    append result $reply_body
    my variable chan
    puts -nonewline $chan $result
    flush $chan
    my destroy
  }
}

oo::class create scgi::app {
  superclass ::httpd::server

  property reply_class ::scgi::reply
  
}

package provide scgi::app 0.1

Added modules/scgi/scgi-server.man.

Added modules/scgi/scgi-server.tcl. 

























































































































































































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

###
# Author: Sean Woods, [email protected]
###
# This file provides the server side implementation of the
# SCGI protocol
###
namespace eval ::scgi {}

proc ::scgi::encode_request {headers body info} {
  variable server_block

  dict set outdict CONTENT_LENGTH [string length $body]
  set outdict [dict merge $outdict $server_block $info]
  dict set outdict PWD [pwd]
  foreach {key value} $headers {
    switch $key {
      SCRIPT_NAME -
      REQUEST_METHOD -
      REQUEST_URI {
        dict set outdict $key $value
      }
      default {
        dict set outdict HTTP_[string map {"-" "_"} [string toupper $key]] $value
      }
    }
  }  
  set result {}
  foreach {name value} $outdict {
    append result $name \x00 $value \x00
  }
  return "[string length $result]:$result,"
}

###
# Redirect a URL to an SCGI service
###
oo::class create ::httpd::reply_scgi {
  superclass httpd::server
  
  property scgi port 10000
  property scgi host 127.0.0.1
  
  method content {} {
    dict with [my meta get scgi] {}
    
    
    set sock [socket $host $port]
    
  }
}


###
# Minimal test harness for the .tests
# Not intended for public consumption
# (But if you find it handy, please steal!)
namespace eval ::scgi::test {}

proc ::scgi::test::send {port text} {
  set sock [socket localhost $port]
  variable reply
  set reply($sock) {}
  chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
  chan event $sock readable [list ::scgi::test::get_reply $sock]
  
  set headers {}
  set body {}
  set read_headers 1
  foreach line [split $text \n] {
    if {$read_headers} {
      if { $line eq {} } {
        set read_headers 0
      } else {
        append headers $line \n
      }
    } else {
      append body $line \n
    }
  }
  set block [::scgi::encode_request $headers $body {}]
  puts -nonewline $sock $block
  flush $sock
  puts -nonewline $sock $body
  flush $sock
  while {$reply($sock) eq {}} {
    update
  }
  #vwait [namespace current]::reply($sock)
  return $reply($sock)
}

proc ::scgi::test::get_reply {sock} {
  variable buffer
  set data [read $sock]
  append buffer($sock) $data
  if {[eof $sock]} {
    chan event $sock readable {}
    set [namespace current]::reply($sock) $buffer($sock)
    unset buffer($sock)
  }
}

namespace eval ::scgi {
  variable server_block {SCGI 1.0 SERVER_SOFTWARE {TclScgiServer/0.1}}
}

package provide scgi::server 0.1

Added modules/scgi/scgi.test. 

















































































































































































































































































































































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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

###
# scgi.test - Copyright (c) 2015 Sean Woods
#
# Unit tests of the SCGI server
###

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

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2

testsNeed TclOO 1

support {
  use mime/mime.tcl mime
  use ooutil/oometa.tcl oo::meta
  use ncgi/ncgi.tcl ncgi
  use httpd/httpd.tcl httpd
}
testing {
  useLocal scgi-server.tcl scgi::server
  useLocal scgi-app.tcl scgi::app
}

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

namespace eval ::scgi::test {}

###
# Build the server
###
oo::class create ::scgi::test::reply {  
  superclass ::scgi::reply

  property reply_headers Content-Type: text/plain


  method error {code {msg {}}} {
    my reset
    my variable data
    if {![info exists data(url)]} {
      set data(url) {}
    }
    set errorstring [my meta getnull error_codes $code]
    my meta set reply_headers Content-Type: {text/plain}
    my meta set reply_status "$code $errorstring"
    my puts "
$code $errorstring
Got the error $code $errorstring

while trying to obtain $data(url)
"
    my output
  }

  method reset {} {
    my variable reply_headers reply_body
    set reply_headers {Status: {200 OK} Content-Type: text/plain}
    set reply_body {}
  }
  
  method content {} {
    my reset
    set dat [my meta get query_headers]
    switch [dict get $dat REQUEST_URI] {
      /time {
	my puts [clock seconds]
      }
      /error {
	error {
The programmer asked me to die this way
	}
      }
      /echo -
      default {
        my variable query_body
        my puts $query_body      
      }
    }
  }
}

oo::class create scgi::test::app {
  superclass ::scgi::app
  
  property reply_class ::scgi::test::reply
}

scgi::test::app create TESTAPP port 10001

test scgi-client-0001 {Do an echo request} {

set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /echo

THIS IS MY CODE
}]
} {Status: 200 OK
Content-Type: text/plain
Content-length: 15

THIS IS MY CODE}

test scgi-client-0002 {Do another echo request} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /echo

THOUGH THERE ARE MANY LIKE IT
}]
} {Status: 200 OK
Content-Type: text/plain
Content-length: 29

THOUGH THERE ARE MANY LIKE IT}

test scgi-client-0003 {Do another echo request} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /echo

THIS ONE ALONE IS MINE
}]
} {Status: 200 OK
Content-Type: text/plain
Content-length: 22

THIS ONE ALONE IS MINE}

test scgi-client-0004 {URL Generates Error} {

set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /error

THIS ONE ALONE IS MINE
}] } {Status: 500 Server Internal Error
Content-Type: text/plain
Content-length: 89

500 Server Internal Error
Got the error 500 Server Internal Error

while trying to obtain}

set checkreply [subst {Status: 200 OK
Content-Type: text/plain
Content-length: 10

[clock seconds]}]

test scgi-client-0005 {URL Different output with a different request} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /time

THIS ONE ALONE IS MINE
}] } $checkreply

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

testsuiteCleanup

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

Changes to support/installation/modules.tcl.

︙︙
118
119
120
121
122
123
124

125
126
127
128
129
130
131

Module  pt           _rde _man  _null
Module  rc4         _tcl  _man  _null
Module  rcs         _tcl  _man  _null
Module  report      _tcl  _man  _null
Module  rest        _tcl  _man  _null
Module  ripemd      _tcl  _man  _null
Module  sasl        _tcl  _man  _exa

Module  sha1        _tcl  _man  _null
Module  simulation  _tcl  _man  _null
Module  smtpd       _tcl  _man _exa
Module  snit        _tcl  _man  _null
Module  soundex     _tcl  _man  _null
Module  stooop      _tcl  _man  _null
Module  string      _tcl  _man  _null








>








118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

Module  pt           _rde _man  _null
Module  rc4         _tcl  _man  _null
Module  rcs         _tcl  _man  _null
Module  report      _tcl  _man  _null
Module  rest        _tcl  _man  _null
Module  ripemd      _tcl  _man  _null
Module  sasl        _tcl  _man  _exa
Module  scgi        _tcl  _man  _null
Module  sha1        _tcl  _man  _null
Module  simulation  _tcl  _man  _null
Module  smtpd       _tcl  _man _exa
Module  snit        _tcl  _man  _null
Module  soundex     _tcl  _man  _null
Module  stooop      _tcl  _man  _null
Module  string      _tcl  _man  _null
︙︙

This page was generated in about 0.068s by Fossil 2.24 [f4ffefe708] 2024-04-17 14:02:19