view release on metacpan or  search on metacpan

t/tcp_rw_stream.t  view on Meta::CPAN

## test 4	make socket listen
print "failed to listen\nnot "
	unless listen($remotsock,SOMAXCONN);
&ok;

*tcp_write = \&Net::DNS::Dig::_tcp_write;
*tcp_read = \&Net::DNS::Dig::_tcp_read;

my $parent = $$;

my $kid = fork;
unless ($kid) {
  # I am the kid

  my($run,$client,$cfileno);

  my $fileno = fileno($remotsock);
  my(@wmsglen, @wmsg);			# write queue
  my $rlen;				# received bytes
  my $buffer;				# receive accumulator
  my $wlen;				# bytes written
  my $wmsglen;				# write message len accumulator
  my $woff = 0;				# write offset into buffer

  my $then = time;
  my $delta;
  my $timeout = 5;			# always a 5 second timeout;

  $run = 1;

  set_NB($remotsock);

  my($rin,$rout,$win,$wout);

  while ($run && (kill 0, $parent)) {
    $rin = $win = '';
    if ($client) {
      vec($rin,$cfileno,1) = 1;
      $win = $rin if @wmsg;		# if write pending
    }
    vec($rin,$fileno,1) = 1;		# listner is always armed
    my $nbfound = select($rout=$rin,$wout=$win,undef,1);
    if ($nbfound > 0) {			# if there is work
      if ($rout && vec($rout,$fileno,1)) {
	close $client if $client;	# close old client if present
	$client = accept_NB($remotsock);
	if ($client) {
	  $cfileno = fileno($client);
	} else {
	  $client = $cfileno = undef;
	}
      }
      if ($rout && $client && vec($rout,$cfileno,1)) {
	if ($rlen = sysread($client,$buffer,65535,0)) {
	  push @wmsglen, $rlen;
	  push @wmsg, $buffer;
	}
      }
      if ($wout && @wmsg) {			# if there is work
	unless ($woff) {			# if not busy
	  $wmsglen = $wmsglen[0];
	}
	if ($wlen = syswrite($client,$wmsg[0],$wmsglen,$woff)) {
	  $wmsglen -= $wlen;
	  $woff += $wlen;

	  unless ($wmsglen > 0) {		# if buffer empty
	    $woff = 0;
	    shift @wmsglen;
	    shift @wmsg;
	  }
	}
      }
    } # end if nbfound
    elsif ($delta = ($_ = time) - $then) {
      $then = $_;
      $timeout -= $delta;
      last if $timeout < 0;
    }
  }
  close $remotsock if $remotsock;
  close $client if $client;
  exit 0;
}

##### PARENT

close $remotsock if $remotsock;		# parent closes remote socket on local side

my $shortstring = 'the quick brown fox jumped over the lazy dog';
my $longstring = '';
my $count = int(65535 / length($shortstring));  # make a long string, bigger than IP_MAXPACKET
  
foreach (1..$count) {
  $longstring .= sprintf("%s %04d\n",$shortstring,$_);       
}

## test 5       open TCP socket

my $localsock = connect_NB($port,INADDR_LOOPBACK);
print "could not connect to server\nnot "
	unless $localsock;
&ok;

# alarm wrapper for tcp_write
sub write_tcp {
  my($sock,$bp,$len) = @_;
  my $wrote = eval {
	local $SIG{ALRM} = sub {};
	alarm 3;
	my $rv = tcp_write($sock,$bp,$len,3);	# write with 3 second timeout
	alarm 0;
	$rv;
  };
  return undef if $@;
  return $wrote;
}

# alarm wrapper for tcp_read
sub read_tcp {