ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import Tcl 8.6.12

Browse Source
This commit is contained in:
Steve Dower
2021-11-08 17:30:58 +00:00
parent 1aadb2455c
commit 674867e7e6
608 changed files with 78089 additions and 60360 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
pkgs/thread2.8.7/tcl/README Normal file
View File

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

310
pkgs/thread2.8.7/tcl/cmdsrv/cmdsrv.tcl Normal file
View File

@@ -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.6
# % 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:

5
pkgs/thread2.8.7/tcl/phttpd/index.htm Normal file
View File

@@ -0,0 +1,5 @@
<html>
<body>
<h3>Hallo World</h3>
</body>
</html>

686
pkgs/thread2.8.7/tcl/phttpd/phttpd.tcl Normal file
View File

@@ -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.6
# % 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:

416
pkgs/thread2.8.7/tcl/phttpd/uhttpd.tcl Normal file
View File

@@ -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.6
# % 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:

576
pkgs/thread2.8.7/tcl/tpool/tpool.tcl Normal file
View File

@@ -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: