bandwidth throttling proxy

vkvalli 16-Aug-2014: This program acts as a bandwidth throttling proxy.

usage:
proxy.tcl <local_port> <remote_host> <remote_port> <bandwidth> <period>
The last parameter <period> is optional.
The bandwidth is in bytes/per second.
Function:
It throttles the downstream bandwidth and not the upstream bandwidth. period regulates the burstness of traffic. The default is 50. This is optimal for interactive applications like rdp. For filetransfer like applications - 200 + might be optimal. The bandwidth applies to each connection and not sum of all connections.
Requirements:
It needs TclOO . So version 8.5 and above required.
Bugs:
error catching on local socket read is not done. It assumes one char is one byte. Keeping period too low, ie 10, will increase cpu load significantly.
Logic:
The core is handler object. It is created on a connection. It's method local_read and remote_read act as handlers for readable fileevent on the channels.
From the bandwidth input, what is the bytes to be read per time-period is calculated. The default time-period is 50 millisec. global variables lbuflength and period carry these values.
There is quota allocated for each time-period. As remote_read keeps reading data from remote_host, this quota keeps decreasing. Once quota becomes zero, remote_read stops reading from chan.
A timer gets activated at the beginning of time-period and sets the quota to max, ie lbuflength. The quota is maintained by instance variable limit.
Methods:
initialize - chan configuration, event handler setup to object methods, starts timer
finalize - channel closing, timer stopping, self-destruction
timer - start - starts the timer, stops - stops it. resets quota on start
local_read - reads local chan
remote_read - if quota available, reads remote, decreases quota
limit_reset - resets quota to max, ie lbuflength
 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