File Coverage

blib/lib/IO/Socket/Forwarder.pm

Criterion	Covered	Total	%
statement	18	180	10.0
branch	0	190	0.0
condition	0	121	0.0
subroutine	6	12	50.0
pod	1	1	100.0
total	25	504	4.9

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);
	my $bitsw = '';
	vec($bitsw, $fn1, 1) = 1 if (($wtw1 && !$ssl_wtr1) || $ssl_wtw1);
	vec($bitsw, $fn2, 1) = 1 if (($wtw2 && !$ssl_wtr2) || $ssl_wtw2);

	$debug and _debug "calling select('$bitsr', '$bitsw')...";

	my $n = select($bitsr, $bitsw, undef, undef);

	$debug and _debug "select done, n: $n";

	if ($n > 0) {
	    if ($wtr1 and vec(($ssl_wtw1 ? $bitsw : $bitsr), $fn1, 1)) {
		$debug and _debug "reading from s1...";
		my $bytes = sysread($s1, $b1to2, $io_chunk_size, length $b1to2);
		$debug and _debug "bytes: " . ($bytes // '');
		if ($bytes) {
		    undef $ssl_wtw1;
		    $debug and _debug "s1 read: " . substr($b1to2, -$bytes);
		}
		elsif ($ssl1 and not defined $bytes) {
		    if (_ssl_error == _ssl_want_write) {
			$ssl_wtw1 = 1;
			$debug and _debug "s1 wants to write for SSL";
		    }
                    elsif (_ssl_error == _ssl_want_read) {
			$debug and _debug "s1 wants to read more for SSL";
                    }
		    else {
			_debug "unexpected SSL error " . _ssl_error;
                        $close{slin} = 1;
		    }
		}
		elsif ($ssl_wtw1) {
		    undef $ssl_wtw1;
		}
		else {
		    $debug and _debug "nothing read from s1, closing schedulled";
		    $close{s1in} = 1;
		}
	    }
	    if ($wtr2 and vec(($ssl_wtw2 ? $bitsw : $bitsr), $fn2, 1)) {
		$debug and _debug "reading from s2...";
		my $bytes = sysread($s2, $b2to1, $io_chunk_size, length $b2to1);
		$debug and _debug "bytes: " . ($bytes // '');
		if ($bytes) {
		    undef $ssl_wtw2;
		    $debug and _debug "s2 read: " . substr($b2to1, -$bytes);
		}
		elsif ($ssl2 and not defined $bytes) {
		    if (_ssl_error == _ssl_want_write) {
			$ssl_wtw2 = 1;
			$debug and _debug "s2 wants to write for SSL";
		    }
                    elsif (_ssl_error == _ssl_want_read) {
			$debug and _debug "s2 wants to read more for SSL";
                    }
		    else {
			_debug "unexpected SSL error " . _ssl_error;
		    }
		}
		elsif ($ssl_wtw2) {
		    undef $ssl_wtw2;
		}
		else {
		    $debug and _debug "nothing read from s2, closing schedulled";
		    $close{s2in} = 1;
		}
	    }
	    if ($wtw1 and vec(($ssl_wtr1 ? $bitsr : $bitsw), $fn1, 1)) {
		$debug and _debug "writting to s1...";
		my $bytes = syswrite($s1, $b2to1, $io_chunk_size);
		$debug and _debug "bytes: " . ($bytes // '');
		if ($bytes) {
		    $debug and _debug "s1 wrote: " . substr($b2to1, 0, $bytes);
		    substr($b2to1, 0, $bytes, "");
		    if ($s2_in_closed and !length $b2to1) {
			$debug and _debug "buffer exhausted and s2-in is closed, shutting down s1-out";
			shutdown($s1, 1) unless $ssl1;
			$s1_out_closed = 1;
		    }
                    $write_chunk_size1 = $io_chunk_size;
		    undef $ssl_wtr1;
		}
		elsif ($ssl1 and not defined $bytes) {
		    if (_ssl_error == _ssl_want_read) {
			$ssl_wtr1 = 1;
			$debug and _debug "s1 wants to read for SSL";
		    }
                    elsif (_ssl_error == _ssl_want_write) {
                        $write_chunk_size1 = length $b2to1 if length $b2to1 < $write_chunk_size1;
			$debug and _debug "s1 wants to write more for SSL, wcs1: $write_chunk_size1";
                    }
		    else {
			_debug "unexpected SSL error " . _ssl_error;
                        $close{s1out} = 1;
		    }
		}
		else {
		    $debug and _debug "nothing written to s1, closing schedulled";
		    $close{s1out} = 1;
		}
	    }
	    if ($wtw2 and vec(($ssl_wtr2 ? $bitsr : $bitsw), $fn2, 1)) {
		$debug and _debug "writting to s2...";
		my $bytes = syswrite($s2, $b1to2, $write_chunk_size2);
		$debug and _debug "bytes: " . ($bytes // '');
		if ($bytes) {
		    $debug and _debug "s2 wrote: " . substr($b1to2, 0, $bytes);
		    substr($b1to2, 0, $bytes, "");
		    if ($s1_in_closed and length $b1to2) {
			$debug and _debug "buffer exhausted and s2-in is closed, shutting down s1-out";
			shutdown($s2, 1) unless $ssl2;
			$s2_out_closed = 1;
		    }
                    $write_chunk_size2 = $io_chunk_size;
		    undef $ssl_wtr2;
		}
		elsif ($ssl2 and not defined $bytes) {
		    if (_ssl_error == _ssl_want_read) {
			$ssl_wtr2 = 1;
			$debug and _debug "s2 wants to read for SSL";
		    }
                    elsif (_ssl_error == _ssl_want_write) {
                        $write_chunk_size2 = length $b1to2 if length $b1to2 < $write_chunk_size2;
			$debug and _debug "s2 wants to write more for SSL, wcs2: $write_chunk_size2";
                    }
		    else {
			_debug "unexpected SSL error " . _ssl_error;
                        $close{s2out} = 1;
		    }
		}
		else {
		    $debug and _debug "nothing written to s1, closing schedulled";
		    $close{s2out} = 1;
		}
	    }
	    if (%close) {
		for (1, 2, 3) { # propagate close flag to dependants
		    if ($ssl1 and ($close{s1in} or $close{s1out})) {
			$close{s1in} = $close{s1out} = 1;
		    }
		    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__