diff options
Diffstat (limited to 'tcl8.6/pkgs/thread2.8.4/tcl')
| -rw-r--r-- | tcl8.6/pkgs/thread2.8.4/tcl/README | 32 | ||||
| -rw-r--r-- | tcl8.6/pkgs/thread2.8.4/tcl/cmdsrv/cmdsrv.tcl | 310 | ||||
| -rw-r--r-- | tcl8.6/pkgs/thread2.8.4/tcl/phttpd/index.htm | 5 | ||||
| -rw-r--r-- | tcl8.6/pkgs/thread2.8.4/tcl/phttpd/phttpd.tcl | 686 | ||||
| -rw-r--r-- | tcl8.6/pkgs/thread2.8.4/tcl/phttpd/uhttpd.tcl | 416 | ||||
| -rw-r--r-- | tcl8.6/pkgs/thread2.8.4/tcl/tpool/tpool.tcl | 576 |
6 files changed, 2025 insertions, 0 deletions
diff --git a/tcl8.6/pkgs/thread2.8.4/tcl/README b/tcl8.6/pkgs/thread2.8.4/tcl/README new file mode 100644 index 0000000..15e1edd --- /dev/null +++ b/tcl8.6/pkgs/thread2.8.4/tcl/README @@ -0,0 +1,32 @@ + +Software here is provided as example of making some interesting +things and applications using the Tcl threading extension. + +Currently, following packages are supplied: + + tpool/ Example Tcl-only implementation of thread pools. + The threading extension includes an efficient + threadpool implementation in C. This file is + provided as a fully functional example on how this + functionality could be implemented in Tcl alone. + + phttpd/ MT-enabled httpd server. It uses threadpool to + distribute incoming requests among several worker + threads in the threadpool. This way blocking + requests may be handled much better, w/o halting + the event loop of the main responder thread. + In this directory you will also find the uhttpd. + This is the same web-server but operating in the + event-loop mode alone, no threadpool support. + This is good for comparison purposes. + + cmdsrv/ Socket command-line server. Each new connection + gets new thread, thus allowing multiple outstanding + blocking calls without halting the event loop. + +To play around with above packages, change to the corresponding +directory and source files in the Tcl8.4 (or later) Tcl shell. +Be sure to have the latest Tcl threading extension installed in +your package path. + +- EOF diff --git a/tcl8.6/pkgs/thread2.8.4/tcl/cmdsrv/cmdsrv.tcl b/tcl8.6/pkgs/thread2.8.4/tcl/cmdsrv/cmdsrv.tcl new file mode 100644 index 0000000..01ec508 --- /dev/null +++ b/tcl8.6/pkgs/thread2.8.4/tcl/cmdsrv/cmdsrv.tcl @@ -0,0 +1,310 @@ +# +# cmdsrv.tcl -- +# +# Simple socket command server. Supports many simultaneous sessions. +# Works in thread mode with each new connection receiving a new thread. +# +# Usage: +# cmdsrv::create port ?-idletime value? ?-initcmd cmd? +# +# port Tcp port where the server listens +# -idletime # of sec to idle before tearing down socket (def: 300 sec) +# -initcmd script to initialize new worker thread (def: empty) +# +# Example: +# +# # tclsh8.4 +# % source cmdsrv.tcl +# % cmdsrv::create 5000 -idletime 60 +# % vwait forever +# +# Starts the server on the port 5000, sets idle timer to 1 minute. +# You can now use "telnet" utility to connect. +# +# Copyright (c) 2002 by Zoran Vasiljevic. +# +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ----------------------------------------------------------------------------- + +package require Tcl 8.4 +package require Thread 2.5 + +namespace eval cmdsrv { + variable data; # Stores global configuration options +} + +# +# cmdsrv::create -- +# +# Start the server on the given Tcp port. +# +# Arguments: +# port Port where the server is listening +# args Variable number of arguments +# +# Side Effects: +# None. +# +# Results: +# None. +# + +proc cmdsrv::create {port args} { + + variable data + + if {[llength $args] % 2} { + error "wrong \# arguments, should be: key1 val1 key2 val2..." + } + + # + # Setup default pool data. + # + + array set data { + -idletime 300000 + -initcmd {source cmdsrv.tcl} + } + + # + # Override with user-supplied data + # + + foreach {arg val} $args { + switch -- $arg { + -idletime {set data($arg) [expr {$val*1000}]} + -initcmd {append data($arg) \n $val} + default { + error "unsupported pool option \"$arg\"" + } + } + } + + # + # Start the server on the given port. Note that we wrap + # the actual accept with a helper after/idle callback. + # This is a workaround for a well-known Tcl bug. + # + + socket -server [namespace current]::_Accept -myaddr 127.0.0.1 $port +} + +# +# cmdsrv::_Accept -- +# +# Helper procedure to solve Tcl shared channel bug when responding +# to incoming socket connection and transfering the channel to other +# thread(s). +# +# Arguments: +# s incoming socket +# ipaddr IP address of the remote peer +# port Tcp port used for this connection +# +# Side Effects: +# None. +# +# Results: +# None. +# + +proc cmdsrv::_Accept {s ipaddr port} { + after idle [list [namespace current]::Accept $s $ipaddr $port] +} + +# +# cmdsrv::Accept -- +# +# Accepts the incoming socket connection, creates the worker thread. +# +# Arguments: +# s incoming socket +# ipaddr IP address of the remote peer +# port Tcp port used for this connection +# +# Side Effects: +# Creates new worker thread. +# +# Results: +# None. +# + +proc cmdsrv::Accept {s ipaddr port} { + + variable data + + # + # Configure socket for sane operation + # + + fconfigure $s -blocking 0 -buffering none -translation {auto crlf} + + # + # Emit the prompt + # + + puts -nonewline $s "% " + + # + # Create worker thread and transfer socket ownership + # + + set tid [thread::create [append data(-initcmd) \n thread::wait]] + thread::transfer $tid $s ; # This flushes the socket as well + + # + # Start event-loop processing in the remote thread + # + + thread::send -async $tid [subst { + array set [namespace current]::data {[array get data]} + fileevent $s readable {[namespace current]::Read $s} + proc exit args {[namespace current]::SockDone $s} + [namespace current]::StartIdleTimer $s + }] +} + +# +# cmdsrv::Read -- +# +# Event loop procedure to read data from socket and collect the +# command to execute. If the command read from socket is complete +# it executes the command are prints the result back. +# +# Arguments: +# s incoming socket +# +# Side Effects: +# None. +# +# Results: +# None. +# + +proc cmdsrv::Read {s} { + + variable data + + StopIdleTimer $s + + # + # Cover client closing connection + # + + if {[eof $s] || [catch {read $s} line]} { + return [SockDone $s] + } + if {$line == "\n" || $line == ""} { + if {[catch {puts -nonewline $s "% "}]} { + return [SockDone $s] + } + return [StartIdleTimer $s] + } + + # + # Construct command line to eval + # + + append data(cmd) $line + if {[info complete $data(cmd)] == 0} { + if {[catch {puts -nonewline $s "> "}]} { + return [SockDone $s] + } + return [StartIdleTimer $s] + } + + # + # Run the command + # + + catch {uplevel \#0 $data(cmd)} ret + if {[catch {puts $s $ret}]} { + return [SockDone $s] + } + set data(cmd) "" + if {[catch {puts -nonewline $s "% "}]} { + return [SockDone $s] + } + StartIdleTimer $s +} + +# +# cmdsrv::SockDone -- +# +# Tears down the thread and closes the socket if the remote peer has +# closed his side of the comm channel. +# +# Arguments: +# s incoming socket +# +# Side Effects: +# Worker thread gets released. +# +# Results: +# None. +# + +proc cmdsrv::SockDone {s} { + + catch {close $s} + thread::release +} + +# +# cmdsrv::StopIdleTimer -- +# +# Cancel the connection idle timer. +# +# Arguments: +# s incoming socket +# +# Side Effects: +# After event gets cancelled. +# +# Results: +# None. +# + +proc cmdsrv::StopIdleTimer {s} { + + variable data + + if {[info exists data(idleevent)]} { + after cancel $data(idleevent) + unset data(idleevent) + } +} + +# +# cmdsrv::StartIdleTimer -- +# +# Initiates the connection idle timer. +# +# Arguments: +# s incoming socket +# +# Side Effects: +# After event gets posted. +# +# Results: +# None. +# + +proc cmdsrv::StartIdleTimer {s} { + + variable data + + set data(idleevent) \ + [after $data(-idletime) [list [namespace current]::SockDone $s]] +} + +# EOF $RCSfile: cmdsrv.tcl,v $ + +# Emacs Setup Variables +# Local Variables: +# mode: Tcl +# indent-tabs-mode: nil +# tcl-basic-offset: 4 +# End: + diff --git a/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/index.htm b/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/index.htm new file mode 100644 index 0000000..324f1f7 --- /dev/null +++ b/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/index.htm @@ -0,0 +1,5 @@ +<html> +<body> +<h3>Hallo World</h3> +</body> +</html> diff --git a/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/phttpd.tcl b/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/phttpd.tcl new file mode 100644 index 0000000..8f0c42d --- /dev/null +++ b/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/phttpd.tcl @@ -0,0 +1,686 @@ +# +# phttpd.tcl -- +# +# Simple Sample httpd/1.0 server in 250 lines of Tcl. +# Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems. +# +# Modified to use namespaces, direct url-to-procedure access +# and thread pool package. Grown little larger since ;) +# +# Usage: +# phttpd::create port +# +# port Tcp port where the server listens +# +# Example: +# +# # tclsh8.4 +# % source phttpd.tcl +# % phttpd::create 5000 +# % vwait forever +# +# Starts the server on the port 5000. Also, look at the Httpd array +# definition in the "phttpd" namespace declaration to find out +# about other options you may put on the command line. +# +# You can use: http://localhost:5000/monitor URL to test the +# server functionality. +# +# Copyright (c) 2002 by Zoran Vasiljevic. +# +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ----------------------------------------------------------------------------- + +package require Tcl 8.4 +package require Thread 2.5 + +# +# Modify the following in order to load the +# example Tcl implementation of threadpools. +# Per default, the C-level threadpool is used. +# + +if {0} { + eval [set TCL_TPOOL {source ../tpool/tpool.tcl}] +} + +namespace eval phttpd { + + variable Httpd; # Internal server state and config params + variable MimeTypes; # Cache of file-extension/mime-type + variable HttpCodes; # Portion of well-known http return codes + variable ErrorPage; # Format of error response page in html + + array set Httpd { + -name phttpd + -vers 1.0 + -root "." + -index index.htm + } + array set HttpCodes { + 400 "Bad Request" + 401 "Not Authorized" + 404 "Not Found" + 500 "Server error" + } + array set MimeTypes { + {} "text/plain" + .txt "text/plain" + .htm "text/html" + .htm "text/html" + .gif "image/gif" + .jpg "image/jpeg" + .png "image/png" + } + set ErrorPage { + <title>Error: %1$s %2$s</title> + <h1>%3$s</h1> + <p>Problem in accessing "%4$s" on this server.</p> + <hr> + <i>%5$s/%6$s Server at %7$s Port %8$s</i> + } +} + +# +# phttpd::create -- +# +# Start the server by listening for connections on the desired port. +# +# Arguments: +# port +# args +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::create {port args} { + + variable Httpd + + set arglen [llength $args] + if {$arglen} { + if {$arglen % 2} { + error "wrong \# args, should be: key1 val1 key2 val2..." + } + set opts [array names Httpd] + foreach {arg val} $args { + if {[lsearch $opts $arg] == -1} { + error "unknown option \"$arg\"" + } + set Httpd($arg) $val + } + } + + # + # Create thread pool with max 8 worker threads. + # + + if {[info exists ::TCL_TPOOL] == 0} { + # + # Using the internal C-based thread pool + # + set initcmd "source ../phttpd/phttpd.tcl" + } else { + # + # Using the Tcl-level hand-crafted thread pool + # + append initcmd "source ../phttpd/phttpd.tcl" \n $::TCL_TPOOL + } + + set Httpd(tpid) [tpool::create -maxworkers 8 -initcmd $initcmd] + + # + # Start the server on the given port. Note that we wrap + # the actual accept with a helper after/idle callback. + # This is a workaround for a well-known Tcl bug. + # + + socket -server [namespace current]::_Accept $port +} + +# +# phttpd::_Accept -- +# +# Helper procedure to solve Tcl shared-channel bug when responding +# to incoming connection and transfering the channel to other thread(s). +# +# Arguments: +# sock incoming socket +# ipaddr IP address of the remote peer +# port Tcp port used for this connection +# +# Side Effects: +# None. +# +# Results: +# None. +# + +proc phttpd::_Accept {sock ipaddr port} { + after idle [list [namespace current]::Accept $sock $ipaddr $port] +} + +# +# phttpd::Accept -- +# +# Accept a new connection from the client. +# +# Arguments: +# sock +# ipaddr +# port +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::Accept {sock ipaddr port} { + + variable Httpd + + # + # Setup the socket for sane operation + # + + fconfigure $sock -blocking 0 -translation {auto crlf} + + # + # Detach the socket from current interpreter/tnread. + # One of the worker threads will attach it again. + # + + thread::detach $sock + + # + # Send the work ticket to threadpool. + # + + tpool::post -detached $Httpd(tpid) [list [namespace current]::Ticket $sock] +} + +# +# phttpd::Ticket -- +# +# Job ticket to run in the thread pool thread. +# +# Arguments: +# sock +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::Ticket {sock} { + + thread::attach $sock + fileevent $sock readable [list [namespace current]::Read $sock] + + # + # End of processing is signalized here. + # This will release the worker thread. + # + + vwait [namespace current]::done +} + + +# +# phttpd::Read -- +# +# Read data from client and parse incoming http request. +# +# Arguments: +# sock +# +# Side Effects: +# None. +# +# Results: +# None. +# + +proc phttpd::Read {sock} { + + variable Httpd + variable data + + set data(sock) $sock + + while {1} { + if {[catch {gets $data(sock) line} readCount] || [eof $data(sock)]} { + return [Done] + } + if {![info exists data(state)]} { + set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]} + if {[regexp $pat $line x data(proto) data(url) data(query)]} { + set data(state) mime + continue + } else { + Log error "bad request line: (%s)" $line + Error 400 + return [Done] + } + } + + # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 + + set state [string compare $readCount 0],$data(state),$data(proto) + switch -- $state { + "0,mime,GET" - "0,query,POST" { + Respond + return [Done] + } + "0,mime,POST" { + set data(state) query + set data(query) "" + } + "1,mime,POST" - "1,mime,GET" { + if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { + set data(mime,[string tolower $key]) $value + } + } + "1,query,POST" { + append data(query) $line + set clen $data(mime,content-length) + if {($clen - [string length $data(query)]) <= 0} { + Respond + return [Done] + } + } + default { + if [eof $data(sock)] { + Log error "unexpected eof; client closed connection" + return [Done] + } else { + Log error "bad http protocol state: %s" $state + Error 400 + return [Done] + } + } + } + } +} + +# +# phttpd::Done -- +# +# Close the connection socket +# +# Arguments: +# s +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::Done {} { + + variable done + variable data + + close $data(sock) + + if {[info exists data]} { + unset data + } + + set done 1 ; # Releases the request thread (See Ticket procedure) +} + +# +# phttpd::Respond -- +# +# Respond to the query. +# +# Arguments: +# s +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::Respond {} { + + variable data + + if {[info commands $data(url)] == $data(url)} { + + # + # Service URL-procedure + # + + if {[catch { + puts $data(sock) "HTTP/1.0 200 OK" + puts $data(sock) "Date: [Date]" + puts $data(sock) "Last-Modified: [Date]" + } err]} { + Log error "client closed connection prematurely: %s" $err + return + } + if {[catch {$data(url) data} err]} { + Log error "%s: %s" $data(url) $err + } + + } else { + + # + # Service regular file path + # + + set mypath [Url2File $data(url)] + if {![catch {open $mypath} i]} { + if {[catch { + puts $data(sock) "HTTP/1.0 200 OK" + puts $data(sock) "Date: [Date]" + puts $data(sock) "Last-Modified: [Date [file mtime $mypath]]" + puts $data(sock) "Content-Type: [ContentType $mypath]" + puts $data(sock) "Content-Length: [file size $mypath]" + puts $data(sock) "" + fconfigure $data(sock) -translation binary -blocking 0 + fconfigure $i -translation binary + fcopy $i $data(sock) + close $i + } err]} { + Log error "client closed connection prematurely: %s" $err + } + } else { + Log error "%s: %s" $data(url) $i + Error 404 + } + } +} + +# +# phttpd::ContentType -- +# +# Convert the file suffix into a mime type. +# +# Arguments: +# path +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::ContentType {path} { + + # @c Convert the file suffix into a mime type. + + variable MimeTypes + + set type "text/plain" + catch {set type $MimeTypes([file extension $path])} + + return $type +} + +# +# phttpd::Error -- +# +# Emit error page +# +# Arguments: +# s +# code +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::Error {code} { + + variable Httpd + variable HttpCodes + variable ErrorPage + variable data + + append data(url) "" + set msg \ + [format $ErrorPage \ + $code \ + $HttpCodes($code) \ + $HttpCodes($code) \ + $data(url) \ + $Httpd(-name) \ + $Httpd(-vers) \ + [info hostname] \ + 80 \ + ] + if {[catch { + puts $data(sock) "HTTP/1.0 $code $HttpCodes($code)" + puts $data(sock) "Date: [Date]" + puts $data(sock) "Content-Length: [string length $msg]" + puts $data(sock) "" + puts $data(sock) $msg + } err]} { + Log error "client closed connection prematurely: %s" $err + } +} + +# +# phttpd::Date -- +# +# Generate a date string in HTTP format. +# +# Arguments: +# seconds +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::Date {{seconds 0}} { + + # @c Generate a date string in HTTP format. + + if {$seconds == 0} { + set seconds [clock seconds] + } + clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1 +} + +# +# phttpd::Log -- +# +# Log an httpd transaction. +# +# Arguments: +# reason +# format +# args +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::Log {reason format args} { + + set messg [eval format [list $format] $args] + set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"] + + puts stderr "\[$stamp\]\[-thread[thread::id]-\] $reason: $messg" +} + +# +# phttpd::Url2File -- +# +# Convert a url into a pathname. +# +# Arguments: +# url +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::Url2File {url} { + + variable Httpd + + lappend pathlist $Httpd(-root) + set level 0 + + foreach part [split $url /] { + set part [CgiMap $part] + if [regexp {[:/]} $part] { + return "" + } + switch -- $part { + "." { } + ".." {incr level -1} + default {incr level} + } + if {$level <= 0} { + return "" + } + lappend pathlist $part + } + + set file [eval file join $pathlist] + + if {[file isdirectory $file]} { + return [file join $file $Httpd(-index)] + } else { + return $file + } +} + +# +# phttpd::CgiMap -- +# +# Decode url-encoded strings. +# +# Arguments: +# data +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::CgiMap {data} { + + regsub -all {\+} $data { } data + regsub -all {([][$\\])} $data {\\\1} data + regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data + + return [subst $data] +} + +# +# phttpd::QueryMap -- +# +# Decode url-encoded query into key/value pairs. +# +# Arguments: +# query +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc phttpd::QueryMap {query} { + + set res [list] + + regsub -all {[&=]} $query { } query + regsub -all { } $query { {} } query; # Othewise we lose empty values + + foreach {key val} $query { + lappend res [CgiMap $key] [CgiMap $val] + } + return $res +} + +# +# monitor -- +# +# Procedure used to test the phttpd server. It responds on the +# http://<hostname>:<port>/monitor +# +# Arguments: +# array +# +# Side Effects: +# None.. +# +# Results: +# None. +# + +proc /monitor {array} { + + upvar $array data ; # Holds the socket to remote client + + # + # Emit headers + # + + puts $data(sock) "HTTP/1.0 200 OK" + puts $data(sock) "Date: [phttpd::Date]" + puts $data(sock) "Content-Type: text/html" + puts $data(sock) "" + + # + # Emit body + # + + puts $data(sock) [subst { + <html> + <body> + <h3>[clock format [clock seconds]]</h3> + }] + + after 1 ; # Simulate blocking call + + puts $data(sock) [subst { + </body> + </html> + }] +} + +# EOF $RCSfile: phttpd.tcl,v $ +# Emacs Setup Variables +# Local Variables: +# mode: Tcl +# indent-tabs-mode: nil +# tcl-basic-offset: 4 +# End: + diff --git a/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/uhttpd.tcl b/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/uhttpd.tcl new file mode 100644 index 0000000..b44338a --- /dev/null +++ b/tcl8.6/pkgs/thread2.8.4/tcl/phttpd/uhttpd.tcl @@ -0,0 +1,416 @@ +# +# uhttpd.tcl -- +# +# Simple Sample httpd/1.0 server in 250 lines of Tcl. +# Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems. +# +# Modified to use namespaces and direct url-to-procedure access (zv). +# Eh, due to this, and nicer indenting, it's now 150 lines longer :-) +# +# Usage: +# phttpd::create port +# +# port Tcp port where the server listens +# +# Example: +# +# # tclsh8.4 +# % source uhttpd.tcl +# % uhttpd::create 5000 +# % vwait forever +# +# Starts the server on the port 5000. Also, look at the Httpd array +# definition in the "uhttpd" namespace declaration to find out +# about other options you may put on the command line. +# +# You can use: http://localhost:5000/monitor URL to test the +# server functionality. +# +# Copyright (c) Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems. +# Copyright (c) 2002 by Zoran Vasiljevic. +# +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ----------------------------------------------------------------------------- + +namespace eval uhttpd { + + variable Httpd; # Internal server state and config params + variable MimeTypes; # Cache of file-extension/mime-type + variable HttpCodes; # Portion of well-known http return codes + variable ErrorPage; # Format of error response page in html + + array set Httpd { + -name uhttpd + -vers 1.0 + -root "" + -index index.htm + } + array set HttpCodes { + 400 "Bad Request" + 401 "Not Authorized" + 404 "Not Found" + 500 "Server error" + } + array set MimeTypes { + {} "text/plain" + .txt "text/plain" + .htm "text/html" + .htm "text/html" + .gif "image/gif" + .jpg "image/jpeg" + .png "image/png" + } + set ErrorPage { + <title>Error: %1$s %2$s</title> + <h1>%3$s</h1> + <p>Problem in accessing "%4$s" on this server.</p> + <hr> + <i>%5$s/%6$s Server at %7$s Port %8$s</i> + } +} + +proc uhttpd::create {port args} { + + # @c Start the server by listening for connections on the desired port. + + variable Httpd + set arglen [llength $args] + + if {$arglen} { + if {$arglen % 2} { + error "wrong \# arguments, should be: key1 val1 key2 val2..." + } + set opts [array names Httpd] + foreach {arg val} $args { + if {[lsearch $opts $arg] == -1} { + error "unknown option \"$arg\"" + } + set Httpd($arg) $val + } + } + + set Httpd(port) $port + set Httpd(host) [info hostname] + + socket -server [namespace current]::Accept $port +} + +proc uhttpd::respond {s status contype data {length 0}} { + + puts $s "HTTP/1.0 $status" + puts $s "Date: [Date]" + puts $s "Content-Type: $contype" + + if {$length} { + puts $s "Content-Length: $length" + } else { + puts $s "Content-Length: [string length $data]" + } + + puts $s "" + puts $s $data +} + +proc uhttpd::Accept {newsock ipaddr port} { + + # @c Accept a new connection from the client. + + variable Httpd + upvar \#0 [namespace current]::Httpd$newsock data + + fconfigure $newsock -blocking 0 -translation {auto crlf} + + set data(ipaddr) $ipaddr + fileevent $newsock readable [list [namespace current]::Read $newsock] +} + +proc uhttpd::Read {s} { + + # @c Read data from client + + variable Httpd + upvar \#0 [namespace current]::Httpd$s data + + if {[catch {gets $s line} readCount] || [eof $s]} { + return [Done $s] + } + if {$readCount == -1} { + return ;# Insufficient data on non-blocking socket ! + } + if {![info exists data(state)]} { + set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]} + if {[regexp $pat $line x data(proto) data(url) data(query)]} { + return [set data(state) mime] + } else { + Log error "bad request line: %s" $line + Error $s 400 + return [Done $s] + } + } + + # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 + + set state [string compare $readCount 0],$data(state),$data(proto) + switch -- $state { + "0,mime,GET" - "0,query,POST" { + Respond $s + } + "0,mime,POST" { + set data(state) query + set data(query) "" + } + "1,mime,POST" - "1,mime,GET" { + if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { + set data(mime,[string tolower $key]) $value + } + } + "1,query,POST" { + append data(query) $line + set clen $data(mime,content-length) + if {($clen - [string length $data(query)]) <= 0} { + Respond $s + } + } + default { + if [eof $s] { + Log error "unexpected eof; client closed connection" + return [Done $s] + } else { + Log error "bad http protocol state: %s" $state + Error $s 400 + return [Done $s] + } + } + } +} + +proc uhttpd::Done {s} { + + # @c Close the connection socket and discard token + + close $s + unset [namespace current]::Httpd$s +} + +proc uhttpd::Respond {s} { + + # @c Respond to the query. + + variable Httpd + upvar \#0 [namespace current]::Httpd$s data + + if {[uplevel \#0 info proc $data(url)] == $data(url)} { + + # + # Service URL-procedure first + # + + if {[catch { + puts $s "HTTP/1.0 200 OK" + puts $s "Date: [Date]" + puts $s "Last-Modified: [Date]" + } err]} { + Log error "client closed connection prematurely: %s" $err + return [Done $s] + } + set data(sock) $s + if {[catch {$data(url) data} err]} { + Log error "%s: %s" $data(url) $err + } + + } else { + + # + # Service regular file path next. + # + + set mypath [Url2File $data(url)] + if {![catch {open $mypath} i]} { + if {[catch { + puts $s "HTTP/1.0 200 OK" + puts $s "Date: [Date]" + puts $s "Last-Modified: [Date [file mtime $mypath]]" + puts $s "Content-Type: [ContentType $mypath]" + puts $s "Content-Length: [file size $mypath]" + puts $s "" + fconfigure $s -translation binary -blocking 0 + fconfigure $i -translation binary + fcopy $i $s + close $i + } err]} { + Log error "client closed connection prematurely: %s" $err + } + } else { + Log error "%s: %s" $data(url) $i + Error $s 404 + } + } + + Done $s +} + +proc uhttpd::ContentType {path} { + + # @c Convert the file suffix into a mime type. + + variable MimeTypes + + set type "text/plain" + catch {set type $MimeTypes([file extension $path])} + + return $type +} + +proc uhttpd::Error {s code} { + + # @c Emit error page. + + variable Httpd + variable HttpCodes + variable ErrorPage + + upvar \#0 [namespace current]::Httpd$s data + + append data(url) "" + set msg \ + [format $ErrorPage \ + $code \ + $HttpCodes($code) \ + $HttpCodes($code) \ + $data(url) \ + $Httpd(-name) \ + $Httpd(-vers) \ + $Httpd(host) \ + $Httpd(port) \ + ] + if {[catch { + puts $s "HTTP/1.0 $code $HttpCodes($code)" + puts $s "Date: [Date]" + puts $s "Content-Length: [string length $msg]" + puts $s "" + puts $s $msg + } err]} { + Log error "client closed connection prematurely: %s" $err + } +} + +proc uhttpd::Date {{seconds 0}} { + + # @c Generate a date string in HTTP format. + + if {$seconds == 0} { + set seconds [clock seconds] + } + clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1 +} + +proc uhttpd::Log {reason format args} { + + # @c Log an httpd transaction. + + set messg [eval format [list $format] $args] + set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"] + + puts stderr "\[$stamp\] $reason: $messg" +} + +proc uhttpd::Url2File {url} { + + # @c Convert a url into a pathname (this is probably not right) + + variable Httpd + + lappend pathlist $Httpd(-root) + set level 0 + + foreach part [split $url /] { + set part [CgiMap $part] + if [regexp {[:/]} $part] { + return "" + } + switch -- $part { + "." { } + ".." {incr level -1} + default {incr level} + } + if {$level <= 0} { + return "" + } + lappend pathlist $part + } + + set file [eval file join $pathlist] + + if {[file isdirectory $file]} { + return [file join $file $Httpd(-index)] + } else { + return $file + } +} + +proc uhttpd::CgiMap {data} { + + # @c Decode url-encoded strings + + regsub -all {\+} $data { } data + regsub -all {([][$\\])} $data {\\\1} data + regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data + + return [subst $data] +} + +proc uhttpd::QueryMap {query} { + + # @c Decode url-encoded query into key/value pairs + + set res [list] + + regsub -all {[&=]} $query { } query + regsub -all { } $query { {} } query; # Othewise we lose empty values + + foreach {key val} $query { + lappend res [CgiMap $key] [CgiMap $val] + } + return $res +} + +proc /monitor {array} { + + upvar $array data ; # Holds the socket to remote client + + # + # Emit headers + # + + puts $data(sock) "HTTP/1.0 200 OK" + puts $data(sock) "Date: [uhttpd::Date]" + puts $data(sock) "Content-Type: text/html" + puts $data(sock) "" + + # + # Emit body + # + + puts $data(sock) [subst { + <html> + <body> + <h3>[clock format [clock seconds]]</h3> + }] + + after 1 ; # Simulate blocking call + + puts $data(sock) [subst { + </body> + </html> + }] +} + +# EOF $RCSfile: uhttpd.tcl,v $ +# Emacs Setup Variables +# Local Variables: +# mode: Tcl +# indent-tabs-mode: nil +# tcl-basic-offset: 4 +# End: + diff --git a/tcl8.6/pkgs/thread2.8.4/tcl/tpool/tpool.tcl b/tcl8.6/pkgs/thread2.8.4/tcl/tpool/tpool.tcl new file mode 100644 index 0000000..021e231 --- /dev/null +++ b/tcl8.6/pkgs/thread2.8.4/tcl/tpool/tpool.tcl @@ -0,0 +1,576 @@ +# +# tpool.tcl -- +# +# Tcl implementation of a threadpool paradigm in pure Tcl using +# the Tcl threading extension 2.5 (or higher). +# +# This file is for example purposes only. The efficient C-level +# threadpool implementation is already a part of the threading +# extension starting with 2.5 version. Both implementations have +# the same Tcl API so both can be used interchangeably. Goal of +# this implementation is to serve as an example of using the Tcl +# extension to implement some very common threading paradigms. +# +# Beware: with time, as improvements are made to the C-level +# implementation, this Tcl one might lag behind. +# Please consider this code as a working example only. +# +# +# +# Copyright (c) 2002 by Zoran Vasiljevic. +# +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ----------------------------------------------------------------------------- + +package require Thread 2.5 +set thisScript [info script] + +namespace eval tpool { + + variable afterevent "" ; # Idle timer event for worker threads + variable result ; # Stores result from the worker thread + variable waiter ; # Waits for an idle worker thread + variable jobsdone ; # Accumulates results from worker threads + + # + # Create shared array with a single element. + # It is used for automatic pool handles creation. + # + + set ns [namespace current] + tsv::lock $ns { + if {[tsv::exists $ns count] == 0} { + tsv::set $ns count 0 + } + tsv::set $ns count -1 + } + variable thisScript [info script] +} + +# +# tpool::create -- +# +# Creates instance of a thread pool. +# +# Arguments: +# args Variable number of key/value arguments, as follows: +# +# -minworkers minimum # of worker threads (def:0) +# -maxworkers maximum # of worker threads (def:4) +# -idletime # of sec worker is idle before exiting (def:0 = never) +# -initcmd script used to initialize new worker thread +# -exitcmd script run at worker thread exit +# +# Side Effects: +# Might create many new threads if "-minworkers" option is > 0. +# +# Results: +# The id of the newly created thread pool. This id must be used +# in all other tpool::* commands. +# + +proc tpool::create {args} { + + variable thisScript + + # + # Get next threadpool handle and create the pool array. + # + + set usage "wrong \# args: should be \"[lindex [info level 1] 0]\ + ?-minworkers count? ?-maxworkers count?\ + ?-initcmd script? ?-exitcmd script?\ + ?-idletime seconds?\"" + + set ns [namespace current] + set tpid [namespace tail $ns][tsv::incr $ns count] + + tsv::lock $tpid { + tsv::set $tpid name $tpid + } + + # + # Setup default pool data. + # + + tsv::array set $tpid { + thrworkers "" + thrwaiters "" + jobcounter 0 + refcounter 0 + numworkers 0 + -minworkers 0 + -maxworkers 4 + -idletime 0 + -initcmd "" + -exitcmd "" + } + + tsv::set $tpid -initcmd "source $thisScript" + + # + # Override with user-supplied data + # + + if {[llength $args] % 2} { + error $usage + } + + foreach {arg val} $args { + switch -- $arg { + -minworkers - + -maxworkers {tsv::set $tpid $arg $val} + -idletime {tsv::set $tpid $arg [expr {$val*1000}]} + -initcmd {tsv::append $tpid $arg \n $val} + -exitcmd {tsv::append $tpid $arg \n $val} + default { + error $usage + } + } + } + + # + # Start initial (minimum) number of worker threads. + # + + for {set ii 0} {$ii < [tsv::set $tpid -minworkers]} {incr ii} { + Worker $tpid + } + + return $tpid +} + +# +# tpool::names -- +# +# Returns list of currently created threadpools +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results +# List of active threadpoool identifiers or empty if none found +# +# + +proc tpool::names {} { + tsv::names [namespace tail [namespace current]]* +} + +# +# tpool::post -- +# +# Submits the new job to the thread pool. The caller might pass +# the job in two modes: synchronous and asynchronous. +# For the synchronous mode, the pool implementation will retain +# the result of the passed script until the caller collects it +# using the "thread::get" command. +# For the asynchronous mode, the result of the script is ignored. +# +# Arguments: +# args Variable # of arguments with the following syntax: +# tpool::post ?-detached? tpid script +# +# -detached flag to turn the async operation (ignore result) +# tpid the id of the thread pool +# script script to pass to the worker thread for execution +# +# Side Effects: +# Depends on the passed script. +# +# Results: +# The id of the posted job. This id is used later on to collect +# result of the job and set local variables accordingly. +# For asynchronously posted jobs, the return result is ignored +# and this function returns empty result. +# + +proc tpool::post {args} { + + # + # Parse command arguments. + # + + set ns [namespace current] + set usage "wrong \# args: should be \"[lindex [info level 1] 0]\ + ?-detached? tpoolId script\"" + + if {[llength $args] == 2} { + set detached 0 + set tpid [lindex $args 0] + set cmd [lindex $args 1] + } elseif {[llength $args] == 3} { + if {[lindex $args 0] != "-detached"} { + error $usage + } + set detached 1 + set tpid [lindex $args 1] + set cmd [lindex $args 2] + } else { + error $usage + } + + # + # Find idle (or create new) worker thread. This is relatively + # a complex issue, since we must honour the limits about number + # of allowed worker threads imposed to us by the caller. + # + + set tid "" + + while {$tid == ""} { + tsv::lock $tpid { + set tid [tsv::lpop $tpid thrworkers] + if {$tid == "" || [catch {thread::preserve $tid}]} { + set tid "" + tsv::lpush $tpid thrwaiters [thread::id] end + if {[tsv::set $tpid numworkers]<[tsv::set $tpid -maxworkers]} { + Worker $tpid + } + } + } + if {$tid == ""} { + vwait ${ns}::waiter + } + } + + # + # Post the command to the worker thread + # + + if {$detached} { + set j "" + thread::send -async $tid [list ${ns}::Run $tpid 0 $cmd] + } else { + set j [tsv::incr $tpid jobcounter] + thread::send -async $tid [list ${ns}::Run $tpid $j $cmd] ${ns}::result + } + + variable jobsdone + set jobsdone($j) "" + + return $j +} + +# +# tpool::wait -- +# +# Waits for jobs sent with "thread::post" to finish. +# +# Arguments: +# tpid Name of the pool shared array. +# jobList List of job id's done. +# jobLeft List of jobs still pending. +# +# Side Effects: +# Might eventually enter the event loop while waiting +# for the job result to arrive from the worker thread. +# It ignores bogus job ids. +# +# Results: +# Result of the job. If the job resulted in error, it sets +# the global errorInfo and errorCode variables accordingly. +# + +proc tpool::wait {tpid jobList {jobLeft ""}} { + + variable result + variable jobsdone + + if {$jobLeft != ""} { + upvar $jobLeft jobleft + } + + set retlist "" + set jobleft "" + + foreach j $jobList { + if {[info exists jobsdone($j)] == 0} { + continue ; # Ignore (skip) bogus job ids + } + if {$jobsdone($j) != ""} { + lappend retlist $j + } else { + lappend jobleft $j + } + } + if {[llength $retlist] == 0 && [llength $jobList]} { + # + # No jobs found; wait for the first one to get ready. + # + set jobleft $jobList + while {1} { + vwait [namespace current]::result + set doneid [lindex $result 0] + set jobsdone($doneid) $result + if {[lsearch $jobList $doneid] >= 0} { + lappend retlist $doneid + set x [lsearch $jobleft $doneid] + set jobleft [lreplace $jobleft $x $x] + break + } + } + } + + return $retlist +} + +# +# tpool::get -- +# +# Waits for a job sent with "thread::post" to finish. +# +# Arguments: +# tpid Name of the pool shared array. +# jobid Id of the previously posted job. +# +# Side Effects: +# None. +# +# Results: +# Result of the job. If the job resulted in error, it sets +# the global errorInfo and errorCode variables accordingly. +# + +proc tpool::get {tpid jobid} { + + variable jobsdone + + if {[lindex $jobsdone($jobid) 1] != 0} { + eval error [lrange $jobsdone($jobid) 2 end] + } + + return [lindex $jobsdone($jobid) 2] +} + +# +# tpool::preserve -- +# +# Increments the reference counter of the threadpool, reserving it +# for the private usage.. +# +# Arguments: +# tpid Name of the pool shared array. +# +# Side Effects: +# None. +# +# Results: +# Current number of threadpool reservations. +# + +proc tpool::preserve {tpid} { + tsv::incr $tpid refcounter +} + +# +# tpool::release -- +# +# Decrements the reference counter of the threadpool, eventually +# tearing the pool down if this was the last reservation. +# +# Arguments: +# tpid Name of the pool shared array. +# +# Side Effects: +# If the number of reservations drops to zero or below +# the threadpool is teared down. +# +# Results: +# Current number of threadpool reservations. +# + +proc tpool::release {tpid} { + + tsv::lock $tpid { + if {[tsv::incr $tpid refcounter -1] <= 0} { + # Release all workers threads + foreach t [tsv::set $tpid thrworkers] { + thread::release -wait $t + } + tsv::unset $tpid ; # This is not an error; it works! + } + } +} + +# +# Private procedures, not a part of the threadpool API. +# + +# +# tpool::Worker -- +# +# Creates new worker thread. This procedure must be executed +# under the tsv lock. +# +# Arguments: +# tpid Name of the pool shared array. +# +# Side Effects: +# Depends on the thread initialization script. +# +# Results: +# None. +# + +proc tpool::Worker {tpid} { + + # + # Create new worker thread + # + + set tid [thread::create] + + thread::send $tid [tsv::set $tpid -initcmd] + thread::preserve $tid + + tsv::incr $tpid numworkers + tsv::lpush $tpid thrworkers $tid + + # + # Signalize waiter threads if any + # + + set waiter [tsv::lpop $tpid thrwaiters] + if {$waiter != ""} { + thread::send -async $waiter [subst { + set [namespace current]::waiter 1 + }] + } +} + +# +# tpool::Timer -- +# +# This procedure should be executed within the worker thread only. +# It registers the callback for terminating the idle thread. +# +# Arguments: +# tpid Name of the pool shared array. +# +# Side Effects: +# Thread may eventually exit. +# +# Results: +# None. +# + +proc tpool::Timer {tpid} { + + tsv::lock $tpid { + if {[tsv::set $tpid numworkers] > [tsv::set $tpid -minworkers]} { + + # + # We have more workers than needed, so kill this one. + # We first splice ourselves from the list of active + # workers, adjust the number of workers and release + # this thread, which may exit eventually. + # + + set x [tsv::lsearch $tpid thrworkers [thread::id]] + if {$x >= 0} { + tsv::lreplace $tpid thrworkers $x $x + tsv::incr $tpid numworkers -1 + set exitcmd [tsv::set $tpid -exitcmd] + if {$exitcmd != ""} { + catch {eval $exitcmd} + } + thread::release + } + } + } +} + +# +# tpool::Run -- +# +# This procedure should be executed within the worker thread only. +# It performs the actual command execution in the worker thread. +# +# Arguments: +# tpid Name of the pool shared array. +# jid The job id +# cmd The command to execute +# +# Side Effects: +# Many, depending of the passed command +# +# Results: +# List for passing the evaluation result and status back. +# + +proc tpool::Run {tpid jid cmd} { + + # + # Cancel the idle timer callback, if any. + # + + variable afterevent + if {$afterevent != ""} { + after cancel $afterevent + } + + # + # Evaluate passed command and build the result list. + # + + set code [catch {uplevel \#0 $cmd} ret] + if {$code == 0} { + set res [list $jid 0 $ret] + } else { + set res [list $jid $code $ret $::errorInfo $::errorCode] + } + + # + # Check to see if any caller is waiting to be serviced. + # If yes, kick it out of the waiting state. + # + + set ns [namespace current] + + tsv::lock $tpid { + tsv::lpush $tpid thrworkers [thread::id] + set waiter [tsv::lpop $tpid thrwaiters] + if {$waiter != ""} { + thread::send -async $waiter [subst { + set ${ns}::waiter 1 + }] + } + } + + # + # Release the thread. If this turns out to be + # the last refcount held, don't bother to do + # any more work, since thread will soon exit. + # + + if {[thread::release] <= 0} { + return $res + } + + # + # Register the idle timer again. + # + + if {[set idle [tsv::set $tpid -idletime]]} { + set afterevent [after $idle [subst { + ${ns}::Timer $tpid + }]] + } + + return $res +} + +# EOF $RCSfile: tpool.tcl,v $ + +# Emacs Setup Variables +# Local Variables: +# mode: Tcl +# indent-tabs-mode: nil +# tcl-basic-offset: 4 +# End: + |