hae Nov 23 2009 - The Tcllib has the multiplexer package which can be used for this purpose, too.
set remote(host) "mush.pennmush.org" ;# host to connect to
set remote(port) "4201" ;# port to connect to
set remote(eol) "lf" ;# should be "lf" if newline_one_char is Yes, or crlf if it's No.
;# Or use "auto" if you prefer, but it may throw out an extra newline before every
;# line of output
set local(port) "1642" ;# where we listen for connections - use "0" to have the program assign a port
proc Server {channel clientaddr clientport} {
global conn remote
set x [incr conn(num)]
Log "Connection from $clientaddr registered (number $x)"
set conn($x,out) $channel
set conn($x,host) $clientaddr
set conn($x,port) $clientport
if { [catch {socket -async $remote(host) $remote(port)} conn($x,in)] } {
close $channel
catch {array unset conn $x,*}
return;
}
fconfigure $conn($x,out) -translation {auto lf} -blocking 0 -buffering line
fconfigure $conn($x,in) -translation {auto auto} -blocking 0 -buffering line
fileevent $conn($x,out) readable [list channelData $x out in]
fileevent $conn($x,in) readable [list channelData $x in out]
};# Server
proc channelData {x 1st 2nd} {
global conn
if { [eof $conn($x,$1st)] || [catch {gets $conn($x,$1st)} data] } {
catch {close $conn($x,in)}
catch {close $conn($x,out)}
if { $1st == "in" } {
Log "Connection from $x's Client died."
} else {
Log "Connection from host on $x died."
}
return;
}
puts $conn($x,$2nd) $data
};# channelData
proc Start {} {
global local conn
array unset conn
set conn(num) 0
set conn(connected) 0
if { [catch {socket -server Server $local(port)} conn(server)] } {
Log "Unable to start Port-Forwarding: $conn(server)"
unset -nocomplain conn(server)
}
set conn(conected) 1
Log "Port-Forwarding Server Connected"
set good 0
foreach x [list www.google.com www.yahoo.com www.whois.sc www.pennmush.org www.talvo.com] {
if { ![catch {socket $x 80} s] } {
Log "Listening for connections on: [lindex [fconfigure $s -sockname] 0]:$local(port)"
set good 1
close $s
break;
}
}
if { !$good } {
Log "Unable to determine home IP. Sorry!"
}
};# Start
proc Log {txt} {
.t insert end "$txt\n"
};# Log
proc main {} {
pack [text .t -yscrollcommand ".s set" -wrap word] -side left -expand 1 -fill both -side left
pack [scrollbar .s -command ".t yview"] -side left -fill y
bind . <F1> {console show}
};# main
main
Start