view release on metacpan or  search on metacpan

t/query.t  view on Meta::CPAN

# of the test code):

$test = 2;

sub ok {
  print "ok $test\n";
  ++$test;
}
## test 2	create echo server
my $remotsock = open_udpNB();
print "could not open UDP socket for testing\nnot "
	unless $remotsock;
&ok;

## test 3	find a usable port for a test server
my $port = dyn_bind($remotsock,INADDR_LOOPBACK);
unless ($port) {
  close $remotsock;
  print "could not bind test socket to port\nnot ";
}
&ok;

my $parent = $$;

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

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

  my(@wmsglen, @wmsg, @who);		# write queue
  my $fileno = fileno($remotsock);
  my $rsin;				# sender address
  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;

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

  while ($run && (kill 0, $parent)) {
    $rin = $win = '';
    vec($rin,$fileno,1) = 1;		# listner is always armed
    $win = $rin if @wmsg;		# if output
    my $nbfound = select($rout=$rin,$wout=$win,undef,1);
    if ($nbfound > 0) {			# if there is work
      if ($rout) {
	if ($rsin = recv($remotsock,$buffer,PACKETSZ,0)) {
	  push @wmsglen, length($buffer);
	  push @wmsg, $buffer;
	  push @who, $rsin;
	}
      }
      if ($wout && @wmsg) {			# if there is work
	unless ($woff) {			# if not busy
	  $wmsglen = $wmsglen[0];
	}
	if ($wlen = send($remotsock,$wmsg[0],0,$who[0])) {
	  $wmsglen -= $wlen;
	  $woff += $wlen;
# udp messages should always be sent in one transmission
	  unless ($wmsglen > 0) {		# if buffer empty
	    $woff = 0;
	    shift @wmsglen;
	    shift @wmsg;
	    shift @who;
	  }
	}
      }
    } # end if nbfound
    elsif ($delta = ($_ = time) - $then) {
      $then = $_;
      $timeout -= $delta;
      last if $timeout < 0;
    }
  }
  close $remotsock if $remotsock;
  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';

# alarm wrapper for test _query
sub  query {
  my($self,$bp,$srv) = @_;
  my $rvp = eval {
	local $SIG{ALRM} = sub {};
	alarm 3;
	my $rv = $self->_query($bp,$srv);
	alarm 0;
	return $rv;
  };
  return undef if $@;
  return $rvp;
}

my $self = {
	Timeout	 => 3,		# 3 seconds
	PeerPort => $port
};

bless $self, 'Net::DNS::Dig';

## test 4	send message, should be echoed

my $msglen = length($shortstring);
my $rvp = query($self,\$shortstring,INADDR_LOOPBACK);

print "failed to send/receive query - error - $!\nnot "
	unless defined $rvp;
&ok;