#!/usr/bin/perl

use strict;
use warnings;

my ($listen_host, $listen_port,
    $connect_host, $connect_port) = @ARGV;

die 'Missing parameters'
  unless $listen_host && $listen_port &&
  $connect_host && $connect_port;

use IO::Handle;
use IO::Select;
use IO::Socket::INET;

my %connections;
my %reverse_in;
my %reverse_ou;
my $conn_id = 0;

my $main_connection = IO::Socket::INET->new
  ( Listen => 100,
    LocalHost => $listen_host,
    LocalPort => $listen_port,
    Blocking => 0  ) or die $!;

my $select_r = IO::Select->new($main_connection);
my $select_w = IO::Select->new;

while (1) {
   my ($read, $write) = IO::Select->select($select_r, $select_w, undef
+, 100)
    or warn "error in select: ".$!;
  foreach my $conn (@{$read}) {
    if ($conn == $main_connection) {
      accept_new_connection($conn);
    } else {
      # this is a regular connection
      read_data($conn);
    }
  }
  foreach my $conn (@{$write}) {
    write_data($conn);
  }
}

sub accept_new_connection {
  my $conn = shift;
  my $incoming = $conn->accept;
  my $outgoing = IO::Socket::INET->new
    ( PeerHost => $connect_host,
      PeerPort => $connect_port,
      Blocking => 0 );
  $outgoing->blocking(0);
  $incoming->blocking(0);
  my $id = $conn_id++;
  $connections{$id} =
    { incoming => $incoming,
      outgoing => $outgoing,
      in_bf => '',
      ou_bf => '',
      id => $id };
  $reverse_in{$incoming} = $id;
  $reverse_ou{$outgoing} = $id;

  # now we add the $incoming and $outgoing as read, and only
  # modify it if some data comes in.
  $select_r->add($incoming);
  $select_r->add($outgoing);

}

sub read_data {
  use bytes;
  my $conn = shift;
  my ($type, $id);
  if (exists $reverse_in{$conn}) {
    $type = 'in';
    $id = $reverse_in{$conn};
  } elsif (exists $reverse_ou{$conn}) {
    $type = 'ou';
    $id = $reverse_ou{$conn};
  }
  my $data = $connections{$id};

  if (!$conn->connected) {
    eval {
      remove_connection($data);
    };
    return;
  }

  my $buf;
  my $read = sysread $conn, $buf, 4096;
  if (!$read) {
    remove_connection($data);
    return;
  }
  $data->{$type.'_bf'} .= $buf;

  if ($type eq 'in') {
    $select_w->add($data->{outgoing});
  } else {
    $select_w->add($data->{incoming});
  }
}

sub write_data {
  use bytes;
  my $conn = shift;
  my ($type, $id);
  if (exists $reverse_in{$conn}) {
    $type = 'ou';
    $id = $reverse_in{$conn};
  } elsif (exists $reverse_ou{$conn}) {
    $type = 'in';
    $id = $reverse_ou{$conn};
  }
  my $data = $connections{$id};

  if (!$conn->connected) {
    eval {
      remove_connection($data);
    };
    return;
  }

  my $buf = $data->{$type.'_bf'};
  my $wrote = syswrite $conn, $buf, length($buf);
  substr($data->{$type.'_bf'}, 0, $wrote, '');

  $select_w->remove($conn)
    unless $data->{$type.'_bf'};

}

sub remove_connection {
  my $data = shift;
  $select_r->remove($data->{incoming}, $data->{outgoing});
  $select_w->remove($data->{incoming}, $data->{outgoing});
  delete $reverse_in{$data->{incoming}};
  delete $reverse_ou{$data->{outgoing}};
  $data->{incoming}->close;
  $data->{outgoing}->close;
  delete $connections{$data->{id}};
}
[download]