File Coverage

blib/lib/IO/BindHandles.pm

Criterion	Covered	Total	%
statement	89	102	87.2
branch	22	40	55.0
condition	20	42	47.6
subroutine	9	10	90.0
pod	5	5	100.0
total	145	199	72.8

package IO::BindHandles;
# ABSTRACT: Bind a set of handles for buffered tunneling

use strict;
use warnings;
use IO::Handle;
use IO::Select;

sub new {
    my $class = shift;
    $class = ref $class || $class;
    my %options = @_;

    my $timeout = 0.5;
    $timeout = $options{timeout} if exists $options{timeout};
    $timeout += 0 if defined $timeout;

    my $handles = $options{handles};
    die "handles must be an ARRAY ref" if ref $handles ne 'ARRAY';
    warn "odd number of handles in BindHandles" if scalar(@$handles) & 1;

    my @all_handles;
    for (my $i = 0; $i < scalar @$handles; $i += 2) {
        my $read = $handles->[$i];
        my $write = $handles->[$i+1];
        $read->autoflush(1);
        $write->autoflush(1);
        my $buffer = '';
        push @all_handles, [ $read, $write, $buffer ];
    }

    my $self = {
                timeout => $timeout,
                handles => \@all_handles,
               };

    bless $self, $class;
    return $self;
}


sub loop {
    my $self = shift;
    $self->timeout(0.1) if defined $self->timeout && $self->timeout == 0;
    #warn "In loop...";
    while ($self->bound()) {
        #warn "rwcycle...";
        $self->rwcycle();
    }
    #warn "Out loop...";
}


sub bound {
    my $self = shift;
    #warn "in bound...";
    my @list =
      grep {
          (
           $_->[0]->opened && $_->[1]->opened &&
           !$_->[0]->error && !$_->[1]->error
          )
            ||
              ( $_->[2] && $_->[1]->opened && !$_->[1]->error )
          } @{$self->{handles}};
    #warn "out bound...";
    return
      scalar @list;
}


sub rwcycle {
    my $self = shift;
    use bytes;
    #warn "in rwcycle...";

    # we listen on all handles all the time for reading...
    my @read_handles = grep { $_->opened && !$_->error }
      map { $_->[0] }
        grep { $_->[1]->opened && !$_->[1]->error }
          @{$self->{handles}};
    #warn "Selecting read on ".join ', ', @read_handles;
    my $read_select = IO::Select->new(@read_handles);


    # but we only listen for writing on those that we have
    # something to write to.
    my @write_handles = grep { $_->opened && !$_->error }
      map { $_->[1] }
        grep { $_->[2] } @{$self->{handles}};
    #warn "Selecting write on ".join ', ', @write_handles;
    my $write_select = IO::Select->new(@write_handles);


    # we check for exception in all handles;
    my @except_handles = (@read_handles, @write_handles);
    #warn "Selecting exception on ".join ', ', @except_handles;
    my $except_select = IO::Select->new(@except_handles);


    # now let's see if there's something to be read or written
    #warn "Select...";
    my ($r_r, $r_w, $e) = IO::Select::select($read_select, $write_select, $except_select, $self->timeout);
    #warn "done...";

    if ($r_r && scalar @$r_r) {
        foreach my $h (@$r_r) {
            my ($h_desc) = grep { $_->[0] eq $h } @{$self->{handles}};
            my $handle = $h_desc->[0];
            my $temp_buf;
            #warn "Reading from $handle.";
            my $num_read = $handle->sysread($temp_buf, 1024);
            if (defined $num_read && $num_read > 0) {
                #warn "Read $num_read";
                $h_desc->[2] .= substr($temp_buf, 0, $num_read);
            } else {
                #warn "Error...";
                $handle->close;
                $h_desc->[3] = 1;
                $h_desc->[1]->close unless $h_desc->[2];
            }
        }
    }

    if ($r_w && scalar @$r_w) {
        foreach my $h (@$r_w) {
            my ($h_desc) = grep { $_->[1] eq $h } @{$self->{handles}};
            my $handle = $h_desc->[1];
            #warn "Writing on $handle.";
            my $num_write = $handle->syswrite($h_desc->[2], length($h_desc->[2]));
            if (defined $num_write && $num_write >= 0) {
                #warn "Wrote $num_write.";
                substr($h_desc->[2],0,$num_write,'');
            } else {
                #warn "Error.";
                $handle->close;
                $h_desc->[0]->close;
            }
        }
    }
    if ($e && scalar @$e) {
        foreach my $h (@$r_w) {
            #warn "Exception in $h";
            my ($h_desc) = grep { $_->[1] eq $h || $_->[0] eq $h } @{$self->{handles}};
            # we close the writing handles unless the
            # exception was in the reading handle and there
            # is still buffered content to be sent.
            unless ($h eq $h_desc->[0] && $h_desc->[2]) {
                $h_desc->[1]->close;
            }
            # in any case we won't read anymore
            $h_desc->[0]->close;
        }
    }

    foreach my $h (@{$self->{handles}}) {
        if (exists $h->[3] && $h->[3] && !$h->[2]) {
            $h->[1]->close()
              unless grep { $_->[0] eq $h->[1] } @{$self->{handles}}
                ;
        }
    }

}


sub timeout {
    my $self = shift;
    my $ret = $self->{timeout};
    $self->{timeout} = shift if @_;
    return $ret;
}


1;

__END__