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