#!/usr/bin/perl -w

=pod

=head1 NAME

portfw - Port forwarder

=head1 SYNOPSYS

portfw [-p pidfile] [local_ip:]local_port[/proto] remote_ip[:remote_port]

=head1 DESCRIPTION

Forwards all incoming request from local_port to remote_port.  If
local_ip is not specified, all addresses on all interfaces are used.
If no remote_port is specified, then the same local_port is assumed
as the default.  If no /proto is specified, tcp is assumed.

=head1 AUTHOR

Rob Brown - bbb@cpan.org

$Id: portfw,v 1.7 2003/07/30 06:50:26 rob Exp $

=cut

use strict;
use Getopt::Long;
use IO::Multiplex::KQueue;
use IO::Socket;

my $pidfile;
GetOptions
  "pidfile=s" => \$pidfile,
  ;

my ($local_addr,$remote_addr)=@ARGV;
die "Missing local port\n" if !$local_addr;
die "Missing remote ip\n" if !$remote_addr;

my ($local_ip, $local_port, $proto,
    $remote_ip,$remote_port);
if ($local_addr =~ s%/(\w+)$%%) {
  $proto = $1;
} else {
  $proto = "tcp";
}
if ($local_addr =~ s%^([\d\.]+):%%) {
  $local_ip = $1;
} else {
  $local_ip = "0.0.0.0";
}
if ($local_addr =~ m%^(\d+)$%) {
  $local_port = $1;
} else {
  die "Invalid local port [$local_addr]\n";
}
if ($remote_addr =~ s%:(\d+)$%%) {
  $remote_port = $1;
} else {
  $remote_port = $local_port;
}
if ($remote_addr =~ m%^([\d\.]+)$%) {
  $remote_ip = $1;
} else {
  die "Invalid remote ip [$remote_addr]\n";
}

print STDERR "Forwarding $proto packets from $local_ip:$local_port to $remote_ip:$remote_port\n";

# Get ready to receive an incoming connection
my $listen = new IO::Socket::INET
  LocalAddr => $local_ip,
  LocalPort => $local_port,
  Proto     => $proto,
  ReuseAddr => 1,
  $proto eq "tcp"?(Listen => 10):(),
  or die "Could not bind local port $local_port/$proto: $!";

# Just test the remote connection once.
my $remote_connect = new IO::Socket::INET
  PeerAddr => $remote_ip,
  PeerPort => $remote_port,
  Proto    => $proto,
  or die "Could not connect to remote $remote_ip:$remote_port/$proto: $!";

if ($proto eq "tcp") {
  # Close the test tcp socket
  $remote_connect->close;
} elsif ($proto eq "udp") {
  # Keep this around for udp replies
} else {
  die "Unimplemented protocol $proto\n";
}

if ($pidfile) {
  if (my $pid = fork) {
    open (PID, ">$pidfile") or die "WARNING: Cannot create $pidfile: $!\n";
    print PID "$pid\n";
    close PID;
    exit;
  } elsif (!defined $pid) {
    die "fork: $!\n";
  }
  $SIG{TERM} = sub {
    unlink $pidfile;
    exit;
  };
} else {
  exit if fork;
}
open STDIN,  "</dev/null";
open STDOUT, ">/dev/null";
open STDERR, ">/dev/null";

my $mux = new IO::Multiplex::KQueue;
$mux->set_callback_object("My::Portfw");
if ($proto eq "tcp") {
  $mux->listen($listen);
} elsif ($proto eq "udp") {
  $My::Portfw::complement{"$listen"} = $remote_connect;
  $My::Portfw::complement{"$remote_connect"} = $listen;
  $mux->add($listen);
  $mux->add($remote_connect);
} else {
  die "Unimplemented proto [$proto]";
}
$mux->loop;
# Never reaches here
exit 1;

package My::Portfw;
use vars qw(%complement);

sub mux_connection {
  my $self = shift;
  my $mux = shift;
  my $fh = shift;
  my $remote_client = new IO::Socket::INET
    PeerAddr => $remote_ip,
    PeerPort => $remote_port,
    Proto    => $proto;
  if (!$remote_client) {
    warn "FAILED!\n";
    # Remote connection failed
    $fh->write("Server Down! $!\n");
    $fh->close;
    return;
  }
  $mux->add($remote_client);
  $complement{"$fh"} = $remote_client;
  $complement{"$remote_client"} = $fh;
  return 1;
}

sub mux_input {
  my $self = shift;
  my $mux  = shift;
  my $fh   = shift;
  my $data = shift;
  if (my $proxy = $complement{"$fh"}) {
    # Consume the packet by sending to its complement socket.
    $proxy->write($$data);
    $$data = "";
  } else {
    # Not sure what to do, close it.
    $$data = "";
    $fh->close;
  }
}

sub mux_eof {
  my $self = shift;
  my $mux  = shift;
  my $fh   = shift;
  my $data = shift;
  if (my $proxy = $complement{"$fh"}) {
    # Consume the packet by sending to its complement socket.
    $proxy->write($$data);
    $$data = "";
    # If this has been closed for writing,
    # then close the complement for writing too.
    $mux->shutdown($proxy, 1);
  }
}

sub mux_close {
  my $self = shift;
  my $mux  = shift;
  my $fh   = shift;
  delete $complement{"$fh"} if exists $complement{"$fh"};
}