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