package require TclOO
set debug_level 3
proc debug {level msg} {
global debug_level
if {$debug_level > $level} {
puts $msg
}
}
oo::class create handler {}
oo::define handler {
method initialize {lchan1 rchan1} {
my variable lchan
my variable rchan
my variable lbuffer
set lchan $lchan1
set rchan $rchan1
fconfigure $lchan -translation binary -buffering none -blocking 0
fconfigure $rchan -translation binary -buffering none -blocking 0
fileevent $lchan readable [list [self] local_read ]
fileevent $rchan readable [list [self] remote_read ]
my timer start
# dumper register [self]
debug 1 "handler [self] created"
}
method finalize {} {
my variable lchan
my variable rchan
my variable lbuffer
my timer stop
catch {close $lchan}
catch {close $rchan}
# dumper deregister [self]
after 0 [self] destroy
}
method local_read {} {
my variable lchan
my variable rchan
if [eof $lchan] {
my finalize
return
}
set data [read $lchan]
if [catch {puts -nonewline $rchan $data}] {
my finalize
}
}
method remote_read {} {
my variable lchan
my variable rchan
my variable limit
if [eof $rchan] {
my finalize
}
if {$limit > 0} {
set data [read $rchan $limit]
incr limit -[string length $data]
if [eof $lchan] {
my finalize
return
}
if [catch {puts -nonewline $lchan $data}] {
my finalize
return
}
}
}
method timer {mode} {
global period
my variable timer_id
switch $mode {
start {
my limit_reset
set timer_id [after $period [list [self] timer start] ]
}
stop {
after cancel $timer_id
}
}
}
method limit_reset {} {
my variable limit
global lbuflength
set limit $lbuflength
}
}
if {[llength $argv] < 4} {
puts "usage: args: lport rhost rport bandwidth"
exit
}
set lport [lindex $argv 0]
set rhost [lindex $argv 1]
set rport [lindex $argv 2]
set bwidth [lindex $argv 3]
set period [lindex $argv 4]
if {$period eq ""} {
set period 50
}
set lbuflength [expr ($bwidth * $period ) / 1000 ]
proc accept {sock addr p} {
global rhost rport
set conn [socket -async $rhost $rport]
set obj_name handler_$sock
handler create $obj_name
$obj_name initialize $sock $conn
}
set server [socket -server accept $lport]
vwait forever