File Coverage

testguts-fork.pl

Criterion	Covered	Total	%
statement	60	67	89.5
branch	11	18	61.1
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	79	93	84.9

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN {
      $| = 1;
      print "1..6\n";                    # 5 tests in total
      }
END {
       print "not ok 1\n" unless $loaded; # we couldn't create an object
    }
use NetServer::Generic;
use IO::Handle;

# first test; can we create a new NetServer::Generic?

my $dummy = new NetServer::Generic();
if (ref($dummy) =~ /NetServer::Generic/i) {
    $loaded = 1;
    print "ok 1\n";
}

# next tests: first, we fork.
# The parent spawns a new NetServer::Generic server. It prints whatever
# comes to it on $out (which is aliased to the original STDOUT).
# The child spawns a NetServer::Generic client() server, with a trigger
# that fires three times. It prints "ok .. $n" each time, and this is picked
# up by the parent (if successful).
#
# The parent prints ok .. 5 when it exits.
#
# Test meanings are:
#
# 1     we could create a NetServer::Generic
# 2 - 5 inclusive: the client repeatedly forked and sent these strings
#       to the server, which echoed them to STDOUT
#
# NOTE: as yet, no testing for the non-forking server is available.
#

my $port = 10101;
my $host = localhost;

no strict "vars";

$j = 1;

$out = *STDOUT;
select STDERR; $| = 1;
select STDOUT; $| = 1;
#select STDIN;

eval {
{
    if ($pid = fork) {
       # parent
       my ($foo) = new NetServer::Generic();
       $foo->port($port);
       $foo->hostname($host);
       #$foo->allowed([ "localhost"]);
       my $server = sub {
           my $self = shift;
           while (defined($tmp = )) {
               if ($tmp !~ /exit/) {
                   print $out "ok $tmp";
		   $val = $tmp; chomp $val;
               } else {
		   if ($val !~ /5/) {
                       exit;
		   } else {
                       $self->quit();
		   }
               }
           }
       };
       $foo->callback($server);
       $foo->mode(forking);
       $foo->run();
       exit;
    } elsif (defined $pid) {
       # child
       my ($foo) = new NetServer::Generic();
       $foo->port($port);
       $foo->hostname($host);
       my $client = sub {
           my $self = shift;
           print STDOUT "$j\nexit\n";
           exit 0;
       };
       $foo->callback($client);
       my $trigger = sub {
           $j++;
           return(($j > 5) ? 0 : 1 ); #make three connections
       };
       $foo->trigger($trigger);
       $foo->mode(client);
       $foo->run();
       exit;
    } elsif ($! =~ /no more processes/i) {
       print $out "not ok 1\n";
       print STDERR "Are you running a Win32 system? If so, this \n",
                    "test script will not and cannot work\n";
       exit 0;
    } else {
       die "Can't fork: $!\n";
       exit 0;
    }
}
}; # end eval

if ($@ ne '') {
   print "eval(): $@\n";
}

exit 0;