+
ADDED examples/httpd/httpd.tcl
Index: examples/httpd/httpd.tcl
==================================================================
--- /dev/null
+++ examples/httpd/httpd.tcl
@@ -0,0 +1,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 ""
+ my puts ""
+ my puts "HELLO WORLD!
"
+ my puts "The time is now [my timestamp]"
+ my puts ""
+ my puts ""
+ }
+}
+
+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 "
+
+
+$code $errorstring
+
+"
+ my puts "
+Got the error $code $errorstring
+
+while trying to obtain $data(url)
+ "
+ my puts "
+"
+ }
+
+ method content {} {
+ set docroot [my 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
Index: modules/httpd/httpd.tcl
==================================================================
--- /dev/null
+++ modules/httpd/httpd.tcl
@@ -0,0 +1,537 @@
+###
+# Author: Sean Woods, yoda@etoyoc.com
+##
+# 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 $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 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 "
+
+
+$code $errorstring
+
+"
+ if {$msg eq {}} {
+ my puts "
+Got the error $code $errorstring
+
+while trying to obtain $data(url)
+ "
+ } else {
+ my puts "
+Guru meditation #[clock seconds]
+
+The server encountered an internal error:
+
+
$msg
+
+For deeper understanding:
+
+
$::errorInfo
+"
+ }
+ my puts "
+"
+ 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 ""
+ my puts ""
+ my puts "HELLO WORLD!
"
+ my puts ""
+ my puts ""
+ }
+
+ ###
+ # 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 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 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 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 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
Index: modules/httpd/httpd.test
==================================================================
--- /dev/null
+++ modules/httpd/httpd.test
@@ -0,0 +1,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
Index: modules/httpd/pkgIndex.tcl
==================================================================
--- /dev/null
+++ modules/httpd/pkgIndex.tcl
@@ -0,0 +1,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
Index: modules/markdown/markdown.tcl
==================================================================
--- /dev/null
+++ modules/markdown/markdown.tcl
@@ -0,0 +1,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 "
"
+ 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_result"
+ }
+ {^[ ]{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 \n \
+ [apply_templates bq_result] \
+ \n
+ }
+ {^\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 $code_result \n
+ }
+ {^(?:(?:`{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 $code_result
+ }
+ {^[ ]{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 "$item_result"
+ set index $peek
+ }
+
+ append result <$list_type>\n \
+ [join $list_result \n] \
+ \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 "\n"
+ append result "\n"
+ append result " \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 " | "
+ } else {
+ append result " | "
+ }
+
+ append result [parse_inline [string trim \
+ [lindex $row_cols $i]]] | "\n"
+ }
+
+ append result "
\n"
+ append result "\n"
+ } else {
+ if {$row_count == 1} {
+ append result "\n"
+ }
+
+ append result " \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 " | "
+ } else {
+ append result " | "
+ }
+
+ append result [parse_inline [string trim \
+ [lindex $row_cols $i]]] | "\n"
+ }
+
+ append result "
\n"
+ }
+
+ incr row_count
+
+ set line [lindex $lines [incr index]]
+
+ if {![regexp {(?:^\s{0,3}|[^\\]+)\|} $line]} {
+ switch $row_count {
+ 1 {
+ append result "
\n"
+ }
+ default {
+ append result "\n"
+ append result "\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"
+ }
+ }
+ }
+ }
+
+ return $result
+ }
+
+ ## \private
+ proc parse_inline {text} {
+ set text [regsub -all -lineanchor {[ ]{2,}$} $text
]
+
+ 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|\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 "[parse_inline $sub]"
+ }
+ 2 {
+ append result "[parse_inline $sub]"
+ }
+ 3 {
+ append result "[parse_inline $sub]"
+ }
+ }
+
+ 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 "[html_escape $sub]"
+ 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 "$txt"
+ } else {
+ append result "$txt"
+ }
+ } else {
+ if {$title ne {}} {
+ append result "![\"$txt\"](\"$url\" "\\"$title\\"/")
"
+ } else {
+ append result ""
+ }
+ }
+
+ 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 "$link"
+ } 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 "$email"
+ }
+ 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 {& & < < > > \" "} $text]
+ }
+}
+
+package provide Markdown 1.0
+
ADDED modules/markdown/pkgIndex.tcl
Index: modules/markdown/pkgIndex.tcl
==================================================================
--- /dev/null
+++ modules/markdown/pkgIndex.tcl
@@ -0,0 +1,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
Index: modules/ooutil/oometa.tcl
==================================================================
--- /dev/null
+++ modules/ooutil/oometa.tcl
@@ -0,0 +1,245 @@
+###
+# Author: Sean Woods, yoda@etoyoc.com
+##
+# 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
Index: modules/ooutil/oooption.tcl
==================================================================
--- /dev/null
+++ modules/ooutil/oooption.tcl
@@ -0,0 +1,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 my lock remove pipeline
+ ###
+ 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
Index: modules/ooutil/ooutil.test
==================================================================
--- modules/ooutil/ooutil.test
+++ modules/ooutil/ooutil.test
@@ -10,11 +10,13 @@
testsNeedTcltest 2
testsNeed TclOO 1
testing {
- useLocal ooutil.tcl oo::util
+ 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 {
@@ -28,13 +30,130 @@
}
} -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:
Index: modules/ooutil/pkgIndex.tcl
==================================================================
--- modules/ooutil/pkgIndex.tcl
+++ modules/ooutil/pkgIndex.tcl
@@ -3,5 +3,7 @@
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
Index: modules/scgi/pkgIndex.tcl
==================================================================
--- /dev/null
+++ modules/scgi/pkgIndex.tcl
@@ -0,0 +1,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
Index: modules/scgi/scgi-app.man
==================================================================
--- /dev/null
+++ modules/scgi/scgi-app.man
ADDED modules/scgi/scgi-app.tcl
Index: modules/scgi/scgi-app.tcl
==================================================================
--- /dev/null
+++ modules/scgi/scgi-app.tcl
@@ -0,0 +1,135 @@
+###
+# Author: Sean Woods, yoda@etoyoc.com
+###
+# 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 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
Index: modules/scgi/scgi-server.man
==================================================================
--- /dev/null
+++ modules/scgi/scgi-server.man
ADDED modules/scgi/scgi-server.tcl
Index: modules/scgi/scgi-server.tcl
==================================================================
--- /dev/null
+++ modules/scgi/scgi-server.tcl
@@ -0,0 +1,107 @@
+###
+# Author: Sean Woods, yoda@etoyoc.com
+###
+# 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
Index: modules/scgi/scgi.test
==================================================================
--- /dev/null
+++ modules/scgi/scgi.test
@@ -0,0 +1,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:
Index: support/installation/modules.tcl
==================================================================
--- support/installation/modules.tcl
+++ support/installation/modules.tcl
@@ -120,10 +120,11 @@
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