File Coverage

blib/lib/POE/Component/Client/SOCKS.pm

Criterion	Covered	Total	%
statement	47	185	25.4
branch	7	54	12.9
condition	0	38	0.0
subroutine	9	20	45.0
pod	5	5	100.0
total	68	302	22.5

package POE::Component::Client::SOCKS;
$POE::Component::Client::SOCKS::VERSION = '1.02';
#ABSTRACT: SOCKS enable any POE Component

use strict;
use warnings;
use Carp;
use Socket;
use POE qw(Wheel::SocketFactory Filter::Stream Wheel::ReadWrite);

sub spawn {
  my $package = shift;
  return $package->_create( 'spawn', @_ );
}

sub connect {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  if ( $self ) {
	$poe_kernel->post( $self->{session_id}, 'connect', @_ );
	return 1;
  }
  my $package = shift;
  return $package->_create( 'connect', @_ );
}

sub bind {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  if ( $self ) {
	$poe_kernel->post( $self->{session_id}, 'bind', @_ );
	return 1;
  }
  my $package = shift;
  return $package->_create( 'bind', @_ );
}

sub _create {
  my $package = shift;
  my $command = shift;
  my %opts = @_;
  $opts{lc $_} = delete $opts{$_} for keys %opts;
  my $options = delete $opts{options};
  my $self = bless { }, $package;
  if ( $command =~ /^(bind|connect)$/ ) {
     unless ( $opts{successevent} and $opts{failureevent} ) {
	warn "You must specify 'SuccessEvent' and 'FailureEvent' for '$command'\n";
        return;
     }
     unless ( $opts{remoteaddress} and $opts{remoteport} ) {
	warn "You must specify 'RemoteAddress' and 'RemotePort'\n";
        return;
     }
     unless ( $opts{socksproxy} ) {
	warn "You must specify 'SocksProxy'\n";
        return;
     }
     if ( $command eq 'bind' and $opts{remoteaddress} !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ ) {
	warn "You specified 'bind' but 'RemoteAddress' is not an IP address\n";
        return;
     }
  }
  $self->{session_id} = POE::Session->create(
	object_states => [
	   $self => { shutdown => '_shutdown',
		      connect  => '_command',
		      bind     => '_command',
	   },
	   $self => [qw(_start
			_disconnect
			_create_socket
			_sock_failed
			_sock_up
			_conn_input
			_conn_error) ],
	],
	heap => $self,
	args => [ $command, %opts ],
	( ref($options) eq 'HASH' ? ( options => $options ) : () ),
  )->ID();
  return $self;
}

sub session_id {
  return $_[0]->{session_id};
}

sub shutdown {
  my $self = shift;
  $poe_kernel->post( $self->{session_id}, 'shutdown' );
  return 1;
}

sub _start {
  my ($kernel,$self,$sender,$command,@args) = @_[KERNEL,OBJECT,SENDER,ARG0..$#_];
  $self->{session_id} = $_[SESSION]->ID();
  $self->{filter} = POE::Filter::Stream->new();
  if ( $command eq 'spawn' ) {
     my $opts = { @args };
     $self->{$_} = $opts->{$_} for keys %{ $opts };
     $kernel->alias_set($self->{alias}) if $self->{alias};
     $kernel->refcount_increment($self->{session_id}, __PACKAGE__) unless $self->{alias};
     return;
  }
  if ( $kernel == $sender ) {
	croak "'connect' and 'bind' should be called from another POE Session\n";
  }
  $self->{sender_id} = $sender->ID();
  $kernel->refcount_increment( $self->{sender_id}, __PACKAGE__ );
  $kernel->yield( $command, @args );
  return;
}

sub _shutdown {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  unless ( $self->{sender_id} ) {
     $kernel->alias_remove($_) for $kernel->alias_list();
     $kernel->refcount_decrement($self->{session_id}, __PACKAGE__) unless $self->{alias};
  }
  $kernel->refcount_decrement( $_->{sender_id}, __PACKAGE__ ) for values %{ $self->{socks} };
  $kernel->refcount_decrement( $_->{sender_id}, __PACKAGE__ ) for values %{ $self->{conns} };
  delete $self->{socks};
  delete $self->{conns};
  return;
}

sub _command {
  my ($kernel,$self,$state,$session,$sender) = @_[KERNEL,OBJECT,STATE,SESSION,SENDER];
  my $args;
  if ( ref $_[ARG0] eq 'HASH' ) {
     $args = $_[ARG0];
  }
  else {
     $args = { @_[ARG0..$#_] };
  }
  $args->{cmd} = $state;
  if ( $session == $sender ) {
     $args->{sender_id} = $self->{sender_id};
  }
  else {
     $args->{lc $_} = delete $args->{$_} for keys %{ $args };
     $args->{sender_id} = $sender->ID();
     unless ( $args->{successevent} and $args->{failureevent} ) {
	warn "You must specify 'SuccessEvent' and 'FailureEvent'\n";
        return;
     }
     unless ( $args->{remoteaddress} and $args->{remoteport} ) {
	warn "You must specify 'RemoteAddress' and 'RemotePort'\n";
        return;
     }
     unless ( $args->{socksproxy} ) {
	warn "You must specify 'SocksProxy'\n";
        return;
     }
     if ( $state eq 'bind' and $args->{remoteaddress} !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ ) {
	warn "You specified 'bind' but 'RemoteAddress' is not an IP address\n";
        return;
     }
     $kernel->refcount_increment( $args->{sender_id}, __PACKAGE__ );
  }
  if ( $state eq 'connect' ) {
    if ( $args->{remoteaddress} =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ ) {
      # SOCKS 4
      $args->{packet} = pack ('CCn', 4, 1, $args->{remoteport}) .
	inet_aton($args->{remoteaddress}) . ( $args->{socks_id} || '' ) . (pack 'x');
    }
    else {
      # SOCKS 4a
      $args->{packet} = pack ('CCn', 4, 1, $args->{remoteport}) .
	inet_aton('0.0.0.1') . ( $args->{socks_id} || '' ) . (pack 'x') .
	$args->{remoteaddress} . (pack 'x');
    }
  }
  else {
    $args->{packet} = pack ('CCn', 4, 2, $args->{remoteport}) .
      inet_aton($args->{remoteaddress}) . ( $args->{socks_id} || '' ) . (pack 'x');
  }
  $kernel->yield( '_create_socket', $args );
  return;
}

sub _create_socket {
  my ($kernel,$self,$args) = @_[KERNEL,OBJECT,ARG0];
  my $factory = POE::Wheel::SocketFactory->new(
    SocketDomain   => AF_INET,
    SocketType     => SOCK_STREAM,
    SocketProtocol => 'tcp',
    RemoteAddress  => $args->{socksproxy},
    RemotePort     => $args->{socksport} || 1080,
    SuccessEvent   => '_sock_up',
    FailureEvent   => '_sock_failed',
  );
  $args->{factory} = $factory;
  $self->{socks}->{ $factory->ID } = $args;
  return;
}

sub _sock_failed {
  my ($kernel,$self,$operation,$errnum,$errstr,$factory_id) = @_[KERNEL,OBJECT,ARG0..ARG3];
  my $args = delete $self->{socks}->{ $factory_id };
  delete $args->{factory};
  delete $args->{packet};
  my $sender_id = delete $args->{sender_id};
  $args->{sockerr} = [ $operation, $errnum, $errstr ];
  $kernel->refcount_decrement( $sender_id, __PACKAGE__ );
  $kernel->post( $sender_id, $args->{failureevent}, $args );
  return;
}

sub _sock_up {
  my ($kernel,$self,$socket,$peeraddr,$peerport,$fact_id) = @_[KERNEL,OBJECT,ARG0..ARG3];
  $peeraddr = inet_aton( $peeraddr );
  my $args = delete $self->{socks}->{ $fact_id };
  delete $args->{factory};
  $args->{socket} = $socket;
  my $wheel = POE::Wheel::ReadWrite->new(
     Handle       => $socket,
     Filter       => $self->{filter},
     InputEvent   => '_conn_input',
     ErrorEvent   => '_conn_error',
  );
  $args->{wheel} = $wheel;
  $self->{conns}->{ $wheel->ID } = $args;
  $wheel->put( $args->{packet} );
  return;
}

sub _conn_input {
  my ($kernel,$self,$input,$wheel_id) = @_[KERNEL,OBJECT,ARG0,ARG1];
  if ( length $input != 8 ) {
     $kernel->yield( '_disconnect', $wheel_id, 'Mangled response from SOCKS proxy' );
     return;
  }
  my @resp = unpack "CCnN", $input;
  unless ( scalar @resp == 4 and $resp[0] eq '0' and $resp[1] =~ /^(90|91|92|93)$/ ) {
     $kernel->yield( '_disconnect', $wheel_id, 'Mangled response from SOCKS proxy' );
     return;
  }
  my ($vn,$cd,$dstport,$dstip) = @resp;
  my $args = delete $self->{conns}->{ $wheel_id };
  delete $args->{wheel};
  delete $args->{packet};
  my $sender_id = delete $args->{sender_id};
  unless ( $cd eq '90' ) {
     delete $args->{socket};
     $args->{socks_error} = $cd;
     $kernel->post( $sender_id, $args->{failureevent}, $args );
     $kernel->refcount_decrement( $sender_id, __PACKAGE__ );
     return;
  }
  $args->{socks_response} = [ $cd, inet_ntoa( pack "N", $dstip ), $dstport ];
  $kernel->post( $sender_id, $args->{successevent}, $args );
  $kernel->refcount_decrement( $sender_id, __PACKAGE__ );
  return;
}

sub _conn_error {
  my ($kernel,$self,$operation,$errnum,$errstr,$wheel_id) = @_[KERNEL,OBJECT,ARG0..ARG3];
  my $args = delete $self->{conns}->{ $wheel_id };
  delete $args->{wheel};
  delete $args->{socket};
  delete $args->{packet};
  my $sender_id = delete $args->{sender_id};
  $args->{sockerr} = [ $operation, $errnum, $errstr ];
  $kernel->post( $sender_id, $args->{failureevent}, $args );
  $kernel->refcount_decrement( $sender_id, __PACKAGE__ );
  return;
}

sub _disconnect {
  my ($kernel,$self,$wheel_id,$reason) = @_[KERNEL,OBJECT,ARG0,ARG1];
  my $args = delete $self->{conns}->{ $wheel_id };
  delete $args->{wheel};
  delete $args->{socket};
  delete $args->{packet};
  my $sender_id = delete $args->{sender_id};
  $args->{socks_unknown} = $reason;
  $kernel->refcount_decrement( $sender_id, __PACKAGE__ );
  $kernel->post( $sender_id, $args->{failureevent}, $args );
  return;
}

'SOCKS it to me!';

__END__