I did not realize until your reply that you would get up to 10,000 debug
prints from sub ReadWrite alone. I changed the debug statements in sub
ReadWrite to only print to STDERR upon failure. I also made other debug
print changes.
Please rerun forkm.t, this time using the one pasted below. There
should only be a hundred lines or so. From the Net-Daemon directory,
please run
perl -Mblib t/forkm.t
on Solaris and post the results.
Thanks
------------------------paste forkm.t
# -*- perl -*-
#
require 5.004;
use strict;
use IO::Socket ();
use Config ();
use Net::Daemon::Test ();
use Fcntl ();
use Config ();
my $debug = 1;
my $dh;
if ($debug) {
$dh = Symbol::gensym();
print STDERR (__LINE__, ": pid $$, ref dh is :", ref($dh), "\n");
open($dh, ">", "forkm.log") or die "Failed to open forkm.log: $!";
}
sub log($) {
my $msg = shift; print STDERR (__LINE__, ": $$ msg is $msg:\n");
print $dh "$$: $msg\n" if $dh;
}
&log("Start");
my $ok;
eval {
if ($^O ne "MSWin32") {
my $pid = fork();
if (defined($pid)) {
if (!$pid) {
# Child
print STDERR (__LINE__, ": child $$ is about to exit\n");
exit 0;
}
}
$ok = 1;
}
};
if (!$ok) {
&log("!ok");
print "1..0\n";
exit;
}
$| = 1;
$^W = 1;
my($handle, $port);
if (@ARGV) {
$port = shift @ARGV; print STDERR ("\n", __LINE__, ": port $port\n");
} else {
($handle, $port) = Net::Daemon::Test->Child
(10, $^X, '-Iblib/lib', '-Iblib/arch', 't/server',
'--mode=fork', 'logfile=stderr', 'debug');
print STDERR ("\n", __LINE__, ": port :$port:\n");
}
sub IsNum {
my $str = shift;
(defined($str) && $str =~ /(\d+)/) ? $1 : undef;
}
# $i is 1 to 10, $j is 9..999
sub ReadWrite {
my $fh = shift; my $i = shift; my $j = shift;
&log("ReadWrite: -> fh=$fh, i=$i, j=$j");
if (!$fh->print("$j\n") || !$fh->flush()) {
print STDERR (__LINE__, ": $$ :$i: :$j: Could not fh->print\n");
die "Child $i: Error while writing $j: " . $fh->error() . " ($!)";
}
my $line = $fh->getline();
if (!defined($line) ) {
print STDERR (__LINE__, ": $$ :$i: :$j: The line is NOT defined\n");
die "Child $i: Error while reading: " . $fh->error() . " ($!)";
} else {
&log("ReadWrite: line=$line");
}
my $num;
if (!defined($num = IsNum($line))) {
print STDERR (__LINE__, ": $$ :$i: :$j: num = IsNum is not
defined\n");
die "Child $i: Cannot parse result: $line";
}
if (!($j*2 == $num)) {
print STDERR (__LINE__, ": $$ :$i: :$j: j*2 ", $j*2, " is not
$num\n");
die "Child $i: Expected " . ($j*2) . ", got $num";
}
&log("ReadWrite: <-");
}
sub MyChild {
my $i = shift; # $i will be 1 to 10
&log("MyChild: -> $i");
eval {
my $fh = IO::Socket::INET->new('PeerAddr' => '127.0.0.1',
'PeerPort' => $port);
print STDERR (__LINE__, ": PeerPort :$port:\n");
if (!$fh) {
print STDERR (__LINE__, ": No fh, cannot connect: $!\n");
&log("MyChild: Cannot connect: $!");
die "Cannot connect: $!";
}
for (my $j = 0; $j < 1000; $j++) {
ReadWrite($fh, $i, $j);
}
};
if ($@) {
print STDERR (__LINE__, "Client: Error $@\n");
&log("MyChild: Client: Error $@");
return 0;
}
&log("MyChild: <-");
print STDERR (__LINE__, ": PeerPort :$port:\n");
return 1;
}
sub ShowResults {
&log("ShowResults: ->");
my @results;
for (my $i = 1; $i <= 10; $i++) {
$results[$i-1] = "not ok $i\n";
}
if (open(LOG, "<log")) {
while (defined(my $line = <LOG>)) {
if ($line =~ /(\d+)/) {
$results[$1-1] = $line;
}
}
}
for (my $i = 1; $i <= 10; $i++) {
print $results[$i-1];
}
&log("ShowResults: <-");
exit 0;
}
my %childs;
sub CatchChild {
&log("CatchChild: ->");
for(;;) {
my $pid = wait;
if ($pid > 0) {
&log("CatchChild: $pid");
if (exists $childs{$pid}) {
print STDERR (__LINE__, ": childs $pid is :",
$childs{$pid}, "\n");
delete $childs{$pid};
if (keys(%childs) == 0) {
print STDERR (__LINE__, ": \%childs is 0\n");
# We ae done when the last of our ten childs are gone.
ShowResults();
print STDERR (__LINE__, ": \n");
last;
} else {
print STDERR (__LINE__, ": Should see this nine
times\n");
}
}
}
}
print STDERR (__LINE__, ": No more childs\n");
$SIG{'CHLD'} = \&CatchChild;
&log("CatchChild: <-");
}
$SIG{'CHLD'} = \&CatchChild;
# Spawn 10 childs, each of them running a series of test
unlink "log";
&log("Spawning childs");
for (my $i = 0; $i < 10; $i++) {
if (defined(my $pid = fork())) {
if ($pid) {
# This is the parent
$childs{$pid} = $i;
print STDERR (__LINE__, ": $$ Created childs $pid\n");
} else {
print STDERR (__LINE__, ": pid $$\n");
&log("Child starting");
# This is the child
undef $handle;
%childs = ();
my $result = MyChild($i);
my $fh = Symbol::gensym();
print STDERR (__LINE__, ": ref fh is :", ref($fh), ":\n");
if (!open($fh, ">>log") || !flock($fh, 2) ||
!seek($fh, 0, 2) ||
!(print $fh (($result ? "ok " : "not ok "), ($i+1), "\n")) ||
!close($fh)) {
print STDERR (__LINE__, "Error while writing log file: $!\n");
exit 1;
}
exit 0;
}
} else {
print STDERR (__LINE__, "Failed to create new child: $!\n");
exit 1;
}
}
my $secs = 120;
while ($secs > 0) {
$secs -= sleep $secs;
}
END {
&log("END: -> handle=" . (defined($handle) ? $handle : "undef"));
if ($handle) {
print STDERR ("\n", __LINE__, " handle $handle\n");
$handle->Terminate();
undef $handle;
}
while (my($var, $val) = each %childs) {
print STDERR ("\n", __LINE__, ": killing child $var and val is
$val\n");
kill 'TERM', $var;
}
%childs = ();
unlink "ndtest.prt";
&log("END: <-");
exit 0;
}
RT for rt.cpan.org