#!C:/perl/bin/perl -w
use strict;
use IO::Socket ();
use Getopt::Long ();
use vars qw($debug $verbose $PORT $TOHOST $TOPORT $DIR);
$PORT = 81;
$TOHOST = "127.0.0.1";
$TOPORT = 80;
$DIR = undef;
$| = 1;
############################################################################
#
# This is main()
#
############################################################################
{
my %o = ('port' => $PORT,
'toport' => $TOPORT,
'tohost' => $TOHOST);
Getopt::Long::GetOptions(\%o, 'debug', 'verbose+', 'port=s', 'toport=s',
'tohost', 'dir=s');
$verbose = 1 if $debug && !$verbose;
my $ah = IO::Socket::INET->new('LocalAddr' => "0.0.0.0",
'LocalPort' => $PORT,
'Reuse' => 1,
'Listen' => 10)
|| die "Failed to bind to local socket: $!";
print "Entering main loop.\n" if $o{'verbose'};
$SIG{'CHLD'} = 'IGNORE';
my $num = 0;
while (1) {
my $ch = $ah->accept();
if (!$ch) {
print STDERR "Failed to accept: $!\n";
next;
}
printf("Accepting client from %s, port %s.\n",
$ch->peerhost(), $ch->peerport()) if $o{'verbose'};
++$num;
my $pid = fork();
if (!defined($pid)) {
print STDERR "Failed to fork: $!\n";
} elsif ($pid == 0) {
# This is the child
$ah->close();
Run(\%o, $ch, $num);
} else {
print "Parent: Forked child, closing socket.\n" if $o{'verbose'};
$ch->close();
}
}
}
sub Run {
my($o, $ch, $num) = @_;
my $th = IO::Socket::INET->new('PeerAddr' => $o->{'tohost'},
'PeerPort' => $o->{'toport'});
print("Child: Connecting tunnel to $o->{'tohost'}, port $o->{'toport'}.\n")
if $o->{'verbose'};
if (!$th) {
printf STDERR ("Child: Failed to connect tunnel to %s, port %s.\n",
$o->{'tohost'}, $o->{'toport'});
exit 0;
}
my $fh;
if ($o->{'dir'}) {
$fh = Symbol::gensym();
open($fh, ">$o->{'dir'}/tunnel$num.log")
or die "Child: Failed to create file $o->{'dir'}/tunnel$num.log: $!";
}
$ch->autoflush();
$th->autoflush();
while ($ch || $th) {
print "Child: Starting loop.\n" if $o->{'verbose'};
my $rin = "";
vec($rin, fileno($ch), 1) = 1 if $ch;
vec($rin, fileno($th), 1) = 1 if $th;
my($rout, $eout);
select($rout = $rin, undef, $eout = $rin, 120);
if (!$rout && !$eout) {
print STDERR "Child: Timeout, terminating.\n";
}
my $cbuffer = "";
my $tbuffer = "";
if ($ch && (vec($eout, fileno($ch), 1) ||
vec($rout, fileno($ch), 1))) {
print "Child: Waiting for client input.\n" if $o->{'verbose'};
my $result = sysread($ch, $tbuffer, 1024);
if (!defined($result)) {
print STDERR "Child: Error while reading from client: $!\n";
exit 0;
}
if ($result == 0) {
print "Child: Client has terminated.\n" if $o->{'verbose'};
exit 0;
}
print "Child: Client input: $cbuffer\n" if $o->{'verbose'};
}
if ($th && (vec($eout, fileno($th), 1) ||
vec($rout, fileno($th), 1))) {
print "Child: Waiting for tunnel input.\n" if $o->{'verbose'};
my $result = sysread($th, $cbuffer, 1024);
if (!defined($result)) {
print STDERR "Child: Error while reading from tunnel: $!\n";
exit 0;
}
if ($result == 0) {
print "Child: Tunnel has terminated.\n" if $o->{'verbose'};
exit 0;
}
print "Child: Tunnel input: $cbuffer\n" if $o->{'verbose'};
}
if ($fh && $tbuffer) {
(print $fh $tbuffer);
}
while (my $len = length($tbuffer)) {
print "Child: Writing $len bytes to tunnel.\n" if $o->{'verbose'};
my $res = syswrite($th, $tbuffer, $len);
print "Child: Wrote $res bytes of $len to tunnel.\n"
if $o->{'verbose'};
if ($res > 0) {
$tbuffer = substr($tbuffer, $res);
} else {
print STDERR "Child: Failed to write to tunnel: $!\n";
}
}
while (my $len = length($cbuffer)) {
print "Child: Writing $len bytes to client.\n" if $o->{'verbose'};
my $res = syswrite($ch, $cbuffer, $len);
print "Child: Wrote $res bytes of $len to child.\n"
if $o->{'verbose'};
if ($res > 0) {
$cbuffer = substr($cbuffer, $res);
} else {
print STDERR "Child: Failed to write to tunnel: $!\n";
}
}
}
}
__END__
=pod
=head1 NAME
tunnel.pl - Create a TCP/IP tunnel between two ports.
=head1 SYNOPSIS
tunnel.pl --port=<num> --tohost=<tohost> --toport=<tonum>
=head1 DESCRIPTION
This script is building a TCP/IP tunnel between two ports. In other
words, it makes you think that a server is listening on your local
machine, port <num>, which is really sitting on host <tohost>, port
<tonum>.
The main purpose of the script is the debugging of client/server
applications, as it includes the ability to log what the client
sends. This is done by using the option --dir=<dir>: If this option
is present, then any new connection will be logged in the files
dir/tunnel0.log, dir/tunnel1.log, and so on.
=head1 CPAN SCRIPT
This script can be found on the CPAN. The following sections are for
CPAN's internal script handling and you can mainly ignore them.
=head2 SCRIPT CATEGORIES
Networking
=head2 README
This script is building a TCP/IP tunnel between two ports. In other
words, it makes you think that a server is listening on your local
machine, port <num>, which is really sitting on host <tohost>, port
<tonum>.
The main purpose of the script is the debugging of client/server
applications, as it includes the ability to log what the client
sends. This is done by using the option --dir=<dir>: If this option
is present, then any new connection will be logged in the files
dir/tunnel0.log, dir/tunnel1.log, and so on.
=head1 AUTHOR
Jochen Wiedmann
[email protected]
=cut
