view release on metacpan or  search on metacpan

lib/IO/Socket/Forwarder.pm  view on Meta::CPAN

package IO::Socket::Forwarder;

our $VERSION = '0.02';

use warnings;
use strict;
use Carp;

use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(forward_sockets);

use constant _default_io_buffer_size => 64 * 1024;
use constant _default_io_chunk_size => 16 * 1024;

sub _debug {
    require Time::HiRes;
    my $time = Time::HiRes::time();
    my @date = localtime $time;
    my $out = "@_";
    $out =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
    warn sprintf("%02d:%02d:%02d.%03d: %s\n",
		 @date[2, 1, 0], 1000 * ($time - int $time), $out);
}

# lazy accessors to IO::Socket::SSL
# we use it but don't depend on it!
sub _ssl_error { $IO::Socket::SSL::SSL_ERROR }
sub _ssl_want_read { IO::Socket::SSL::SSL_WANT_READ() }
sub _ssl_want_write { IO::Socket::SSL::SSL_WANT_WRITE() }

sub _min { $_[0] < $_[1] ? $_[0] : $_[1] }

sub forward_sockets {
    my ($s1, $s2, %opts) = @_;

    my $debug = delete $opts{debug};
    $debug = $IO::Socket::Forwarder::debug unless defined $debug;

    my $io_buffer_size = delete $opts{io_buffer_size} || _default_io_buffer_size;
    my $io_chunk_size  = delete $opts{io_chunk_size}  || _default_io_chunk_size;

    my $fn1 = fileno $s1;
    defined $fn1 or croak "socket 1 is not a valid file handle";
    my $fn2 = fileno $s2;
    defined $fn1 or croak "socket 2 is not a valid file handle";

    my $ssl1 = $s1->isa('IO::Socket::SSL');
    my $ssl2 = $s2->isa('IO::Socket::SSL');

    $debug and _debug "s1 fn=$fn1, ssl=$ssl1";
    $debug and _debug "s2 fn=$fn2, ssl=$ssl2";

    my $b1to2 = delete $opts{buffer_1to2} // '';
    my $b2to1 = delete $opts{buffer_2to1} // '';

    if ($debug) {
	_debug "b1to2: $b1to2";
	_debug "b2to1: $b2to1";
    }

    my ($write_chunk_size1, $write_chunk_size2) = ($io_chunk_size, $io_chunk_size);

    my ($s1_in_closed, $s2_in_closed,
        $s1_out_closed, $s2_out_closed,
        $ssl_wtr1, $ssl_wtw1, $ssl_wtr2, $ssl_wtw2,
        %close);

    unless ($^O =~ /Win32/) {
	fcntl($s1, F_SETFL, fcntl($s1, F_GETFL, 0) | O_NONBLOCK)
	    or croak "unable to make socket 1 non-blocking";
	fcntl($s2, F_SETFL, fcntl($s2, F_GETFL, 0) | O_NONBLOCK)
	    or croak "unable to make socket 2 non-blocking";
    }

    if (0 and $debug) {
	_debug "delaying...";
	sleep 5;
	_debug "starting...";
    }

    while (1) {
	my $wtr1 = (not $s1_in_closed and length $b1to2 < $io_buffer_size);
        if ($ssl1 and $wtr1 and $s1->pending) {
            sysread($s1, $b1to2, _min($s1->pending, $io_buffer_size), length $b1to2)
                and redo;
        }

	my $wtr2 = (not $s2_in_closed and length $b2to1 < $io_buffer_size);
        if ($ssl2 and $wtr2 and $s2->pending) {
            sysread($s2, $b2to1, _min($s2->pending, $io_buffer_size), length $b2to1)
                and redo;
        }

	my $wtw1 = (not $s1_out_closed and length $b2to1);
	my $wtw2 = (not $s2_out_closed and length $b1to2);

	$debug and _debug "wtr1: $wtr1, wtr2: $wtr2, wtw1: $wtw1, wtw2: $wtw2";

	unless ($wtr1 or $wtr2 or $wtw1 or $wtw2) {
	    $debug and _debug "nothing else to do, exiting...";
	    last;
	}



	my $bitsr = '';
	vec($bitsr, $fn1, 1) = 1 if (($wtr1 && !$ssl_wtw1) || $ssl_wtr1);
	vec($bitsr, $fn2, 1) = 1 if (($wtr2 && !$ssl_wtw2) || $ssl_wtr2);

lib/IO/Socket/Forwarder.pm  view on Meta::CPAN

		    }
		    if ($ssl2 and ($close{s2in} or $close{s2out})) {
			$close{s2in} = $close{s2out} = 1;
		    }
		    if ($close{s1in} and !length $b1to2) {
			$close{s2out} = 1;
		    }
		    if ($close{s2in} and !length $b2to1) {
			$close{s1out} = 1;
		    }
		}
		if ($close{s1in}) {
		    $debug and _debug "shutdown s1 in";
		    shutdown($s1, 0);
		    $s1_in_closed = 1;
		}
		if ($close{s2in}) {
		    $debug and _debug "shutdown s2 in";
		    shutdown($s2, 0);
		    $s2_in_closed = 1;
		}
		if ($close{s1out}) {
		    $debug and _debug "shutdown s1 out";
		    shutdown($s1, 1);
		    $s1_out_closed = 1;
		}
		if ($close{s2out}) {
		    $debug and _debug "shutdown s1 out";
		    shutdown($s2, 1);
		    $s2_out_closed = 1;
		}
	    }
	    %close = ();
	}
    }
    shutdown($s1, 2);
    shutdown($s2, 2);
}

1;

__END__

=head1 NAME

IO::Socket::Forwarder - bidirectionally forward data between two sockets

=head1 SYNOPSIS

  use IO::Socket::Forwarder qw(foward_sockets);

  forward_sockets($sock1, $sock2);

  forward_sockets($sock3, $sock4, debug => 1);


=head1 DESCRIPTION

This module allows to forward data between two sockets bidirectionally.

IO::Socket::SSL sockets are also supported.

=head2 FUNCTIONS

=over 4

=item forward_sockets($sock1, $sock2, %opts)

Reads and writes data from both sockets simultaneously forwarding it.

On return both sockets will be closed.

This function automatically detects if any of the sockets is of type
L<IO::Socket::SSL> and doesn't require any extra configuration to
handle them.

The following options are accepted:

=over 4

=item debug => 1

turn on debugging. I

=item io_chunk_size => $size

maximun number of bytes allowed in IO operations

=item io_buffer_size => $size

size of the buffers used internally to transfer data between both sockets

=item buffer_1to2 => $data

=item buffer_2to1 => $data

these options allow to preload some data into the buffers used for
transferring data between the two sockets.

=back

=back

=head1 SEE ALSO

L<IO::Socket>, L<IO::Socket::SSL>.

The samples directory contains a couple of scripts showing how to use
this module.

=head1 BUGS AND SUPPORT

Please report any bugs or feature requests through the web interface
at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IO-Socket-Forwarder>
or just send my an email with the details.

=head1 AUTHOR

Salvador FandiE<ntilde>o (sfandino@yahoo.com).

=head1 COPYRIGHT

Copyright 2009-2010 by Qindel Formacion y Servicios S.L.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.