Richard Suchenwirth 2006-09-17 - CGI is a mighty complex protocol for web servers to provide active content (i.e. the results of a script). The following is just a poor subset of CGI, but then again, it's not much code either. And testing it was great fun :^)
I started from DustMote, a web server for static content in 41 lines of code, and added the following features:
Here's my extended version of DustMote, still short at 42 lines of code:
# DustMotePlus - with a subset of CGI support
set root c:/html
set default index.htm
set port 80
set encoding iso8859-1
proc bgerror msg {puts stdout "bgerror: $msg\n$::errorInfo"}
proc answer {socketChannel host2 port2} {
fileevent $socketChannel readable [list serve $socketChannel]
}
proc serve sock {
fconfigure $sock -blocking 0
gets $sock line
if {[fblocked $sock]} return
fileevent $sock readable ""
set tail /
regexp {(/[^ ?]*)(\?[^ ]*)?} $line -> tail args
if {[string match */ $tail]} {append tail $::default}
set name [string map {%20 " "} $::root$tail]
if {[file readable $name]} {
puts $sock "HTTP/1.0 200 OK"
if {[file extension $name] eq ".tcl"} {
set ::env(QUERY_STRING) [string range $args 1 end]
set name [list |tclsh $name]
} else {
puts $sock "Content-Type: text/html;charset=$::encoding\n"
}
set inchan [open $name]
fconfigure $inchan -translation binary
fconfigure $sock -translation binary
fcopy $inchan $sock -command [list done $inchan $sock]
} else {
puts $sock "HTTP/1.0 404 Not found\n"
close $sock
}
}
proc done {file sock bytes {msg {}}} {
close $file
close $sock
}
socket -server answer $port
puts "Server ready..."
vwait foreverAnd here's a little "CGI" script I tested it with (save as time.tcl):
# time.tcl - tiny CGI script.
if ![info exists env(QUERY_STRING)] {set env(QUERY_STRING) " "}
puts "Content-type: text/html\n"
puts "<html><head><title>Tiny CGI time server</title></head>
<body><h1>Time server</h1>
Time now is: [clock format [clock seconds]]<br>
Query was: $env(QUERY_STRING)
<hr>
<a href=index.htm>Index</a>
</body></html>"MS prefers to use fcopy (so that the output proceeds in the background and the server is responsive to new queries while the cgi script is running). - RS: thanks - integrated in the above code :^)
DDG I prefere to use namespaces and I was adding some more MimeTypes because I like and need CSS and JavaScript.
# DustMotePlusPlus - with a subset of CGI support
# and namespace dmhttpd and more MimeTypes
namespace eval dmhttpd {
variable root /home/dgroth/html
variable default index.htm
variable port 8088
variable encoding iso8859-1
variable MimeTypes
array set MimeTypes {
{} "text/plain"
.txt "text/plain"
.css "text/css"
.js "text/javascript"
.htm "text/html;charset=$encoding"
.html "text/html;charset=$encoding"
.tml "text/html;charset=$encoding"
.gif "image/gif"
.jpg "image/jpeg"
.ico "image/ico"
.png "image/png"
}
}
proc dmhttpd::answer {socketChannel host2 {port2 ""}} {
variable port
if {$port2 ne ""} {
set port $port2
}
fileevent $socketChannel readable [list ::[namespace current]::serve $socketChannel]
}
proc dmhttpd::serve {sock} {
variable root
variable MimeTypes
variable default
fconfigure $sock -blocking 0
gets $sock line
if {[fblocked $sock]} return
fileevent $sock readable ""
set tail /
regexp {(/[^ ?]*)(\?[^ ]*)?} $line -> tail args
if {[string match */ $tail]} {append tail $default}
set name [string map {%20 " "} $root$tail]
if {[file readable $name]} {
puts $sock "HTTP/1.0 200 OK"
if {[file extension $name] eq ".tcl"} {
set ::env(QUERY_STRING) [string range $args 1 end]
set name [list |tclsh $name]
} else {
set ext [string tolower [file extension $name]]
puts $sock "Content-Type: $MimeTypes($ext)\n"
}
set inchan [open $name]
fconfigure $inchan -translation binary
fconfigure $sock -translation binary
fcopy $inchan $sock -command [list ::[namespace current]::done $inchan $sock]
} else {
puts $sock "HTTP/1.0 404 Not found\n"
close $sock
}
}
proc dmhttpd::done {file sock bytes {msg {}}} {
close $file
close $sock
}
if {[info script] eq $argv0} {
proc bgerror msg {puts stdout "bgerror: $msg\n$::errorInfo"}
socket -server ::dmhttpd::answer 8088
puts "Server ready..."
vwait forever
}