package require TclOO package require tcl::chan::fifo 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
global lbuflength
my variable limit
if [eof $rchan] {
my finalize
}
if {$limit > 0} {
set data [read $rchan $limit]
# set data [read $rchan ]
incr limit -[string length $data]
# incr limit 10
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 / 100 # set period 10
set lbuflength [expr ($bwidth * $period ) / 1000 ]
# set period 10 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