#!/usr/local/bin/perl -Tw

use strict;
use warnings;
use Socket;
use Carp;

my %rules = (
    'client' => {
        'talkback_rule' => {
            pattern => qr/tmtowtdi$/,
            action  => sub {
                           print CLIENT 'Yes, there is!';
                       },
        },
    },
    'server' => {
        'sneeze_rule' => {
            pattern => qr/achoo$/i,
            action  => sub {
                           print CLIENT 'Geshunteit!';
                       },
        },
    },
);

my $maxbuflength = 16 * 1024;

my $EOL = "\015\012";

sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

# port we listen on
my $listen_port = shift @ARGV || 1234;

# address we connect to
my $server_host = shift @ARGV || 'localhost';
my $server_port = shift @ARGV || 4321;

my $proto = getprotobyname( 'tcp' );

# listen for an incoming connection; see perlipc
socket( PROXY, PF_INET, SOCK_STREAM, $proto )          || die "socket:
+ $!";
setsockopt( PROXY, SOL_SOCKET, SO_REUSEADDR,
    pack( "l", 1 ) )                                   || die "setsock
+opt: $!";
bind( PROXY, sockaddr_in( $listen_port, INADDR_ANY ) ) || die "bind: $
+!";
listen( PROXY, SOMAXCONN )                             || die "listen:
+ $!";

logmsg "server started on port $listen_port";

my $paddr;

for ( ; $paddr = accept( CLIENT, PROXY ); close CLIENT ) {
    my( $port, $iaddr ) = sockaddr_in( $paddr );
    my $name = gethostbyaddr( $iaddr, AF_INET );
 
    logmsg "connection from $name [",
        inet_ntoa($iaddr), "]
        at port $port";
 
    # here the meat
    my $riaddr = inet_aton( $server_host );
    my $rpaddr = sockaddr_in( $server_port, $riaddr );
    
    socket( SERVER, PF_INET, SOCK_STREAM, $proto ) or die "socket: $!"
+;
    connect( SERVER, $rpaddr ) or die "connect: $!";

    logmsg "connected to $server_host:$server_port";
    
    # autoflush everything
    select SERVER; $|++;
    select CLIENT; $|++;
    select STDOUT; $|++;
    
    # stdin is a control connection
    my $rstdin = '';
    vec( $rstdin, fileno( STDIN ), 1 ) = 1;
    
    # server is the remote host we connected to
    my $rserver = '';
    vec( $rserver, fileno( SERVER ), 1 ) = 1;
    
    # client is the host that connected to us
    my $rclient = '';
    vec( $rclient, fileno( CLIENT ), 1 ) = 1;
    
    my $commandbuf = ''; # stuff read from stdin
    my $serverbuf = ''; # stuff read from server
    my $clientbuf = ''; # stuff read from client
    my $iobuf; # intermediate buffer
    
    while ( 1 ) {
        my $rout = '';
        my $rin = $rserver | $rclient | $rstdin;
    
        select( $rout = $rin, undef, undef, 0.01 );
    
        my $gotstdin = vec( $rout, fileno( STDIN ), 1 );
        my $gotserver = vec( $rout, fileno( SERVER ), 1 );
        my $gotclient = vec( $rout, fileno( CLIENT ), 1 );
    
        #printf "%vxd\n", $rout;
        
        if ( $gotserver ) {
            exit unless defined read( SERVER, $iobuf, 1 );
            print CLIENT $iobuf; # proxy server->client
    
            if ( length $serverbuf > $maxbuflength ) {
                $serverbuf = substr( $serverbuf, 1 ) . $iobuf;
            }
            else {
                $serverbuf .= $iobuf;
            }
            handleData( $serverbuf, 'server' );
        }

        if ( $gotclient ) {
            exit unless defined read( CLIENT, $iobuf, 1 );
            print SERVER $iobuf; # proxy client->server

            if ( length $clientbuf > $maxbuflength ) {
                $clientbuf = substr( $clientbuf, 1 ) . $iobuf;
            }
            else {
                $clientbuf .= $iobuf;
            }
            handleData( $clientbuf, 'client' );
        }
        
        if ( $gotstdin ) {
            read( STDIN, $iobuf, 1 );
            $commandbuf .= $iobuf;

            print "stdin: $iobuf\n";

            if ( $iobuf eq "\n" ) {
                # process complete command
                if ( lc $commandbuf eq "quit" ) {
                    exit;
                }
                else {
                    print STDERR "unknown command $commandbuf\n";
                }
                $commandbuf = "";
            }
        }
    }
}

sub handleData {
    my $data = shift;
    my $ruleset = shift;

    if ( open TRACE, "> trace.$ruleset" ) {
        print TRACE $data;
        close TRACE;
    }

    die "unknown ruleset $ruleset" unless exists $rules{ $ruleset };

    for my $rulename ( keys %{ $rules{ $ruleset } } ) {
        if ( $data =~ $rules{ $ruleset }{ $rulename }{ pattern } ) {
            $rules{ $ruleset }{ $rulename }{ action }->( );
            print STDERR "matched rule $ruleset->$rulename\n";
        }
    }
}
[download]