defined @array and defined %hash need no warnings 'deprecated';

[p5sagit/p5-mst-13.2.git] / t / op / fork.t

diff --git a/t/op/fork.t b/t/op/fork.t
old mode 100755 (executable)
new mode 100644 (file)
index 11efa79..9fe8107
--- a/t/op/fork.t
+++ b/t/op/fork.t
@@ -4,16 +4,19 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    unshift @INC, '../lib';
+    @INC = '../lib';
     require Config; import Config;
-    unless ($Config{'d_fork'}
-           or ($^O eq 'MSWin32' and $Config{useithreads}
-               and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/))
-    {
+    unless ($Config{'d_fork'} or $Config{'d_pseudofork'}) {
        print "1..0 # Skip: no fork\n";
        exit 0;
     }
     $ENV{PERL5LIB} = "../lib";
+    require './test.pl';
+}
+
+if ($^O eq 'mpeix') {
+    print "1..0 # Skip: fork/status problems on MPE/iX\n";
+    exit 0;
 }
 
 $|=1;
@@ -22,11 +25,10 @@ undef $/;
 @prgs = split "\n########\n", <DATA>;
 print "1..", scalar @prgs, "\n";
 
-$tmpfile = "forktmp000";
-1 while -f ++$tmpfile;
-END { unlink $tmpfile if $tmpfile; }
+$tmpfile = tempfile();
+END { close TEST }
 
-$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat');
+$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat'));
 
 for (@prgs){
     my $switch;
@@ -44,16 +46,21 @@ for (@prgs){
     if ($^O eq 'MSWin32') {
       $results = `.\\perl -I../lib $switch $tmpfile 2>&1`;
     }
+    elsif ($^O eq 'NetWare') {
+      $results = `perl -I../lib $switch $tmpfile 2>&1`;
+    }
     else {
       $results = `./perl $switch $tmpfile 2>&1`;
     }
     $status = $?;
     $results =~ s/\n+$//;
-    $results =~ s/at\s+forktmp\d+\s+line/at - line/g;
-    $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g;
+    $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g;
+    $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g;
 # bison says 'parse error' instead of 'syntax error',
 # various yaccs may or may not capitalize 'syntax'.
     $results =~ s/^(syntax|parse) error/syntax error/mig;
+    $results =~ s/^\n*Process terminated by SIG\w+\n?//mg
+       if $^O eq 'os2';
     my @results = sort split /\n/, $results;
     if ( "@results" ne "@expected" ) {
        print STDERR "PROG: $switch\n$prog\n";
@@ -85,6 +92,24 @@ ok 1
 ok 2
 ########
 $| = 1;
+if ($cid = fork) {
+    sleep 1;
+    print "not " unless kill 'INT', $cid;
+    print "ok 2\n";
+}
+else {
+    # XXX On Windows the default signal handler kills the
+    # XXX whole process, not just the thread (pseudo-process)
+    $SIG{INT} = sub { exit };
+    print "ok 1\n";
+    sleep 5;
+    die;
+}
+EXPECT
+ok 1
+ok 2
+########
+$| = 1;
 sub forkit {
     print "iteration $i start\n";
     my $x = fork;
@@ -177,6 +202,28 @@ child 3
 [1] -2- -3-
 -1- -2- -3-
 ########
+$| = 1;
+foreach my $c (1,2,3) {
+    if (fork) {
+       print "parent $c\n";
+    }
+    else {
+       print "child $c\n";
+       exit;
+    }
+}
+while (wait() != -1) { print "waited\n" }
+EXPECT
+child 1
+child 2
+child 3
+parent 1
+parent 2
+parent 3
+waited
+waited
+waited
+########
 use Config;
 $| = 1;
 $\ = "\n";
@@ -198,6 +245,7 @@ EXPECT
 ########
 $| = 1;
 use Cwd;
+my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works.
 $\ = "\n";
 my $dir;
 if (fork) {
@@ -224,7 +272,7 @@ ok 1 child
 $| = 1;
 $\ = "\n";
 my $getenv;
-if ($^O eq 'MSWin32') {
+if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
     $getenv = qq[$^X -e "print \$ENV{TST}"];
 }
 else {
@@ -320,3 +368,97 @@ BEGIN {
 #print "outer\n"
 EXPECT
 inner
+########
+sub pipe_to_fork ($$) {
+    my $parent = shift;
+    my $child = shift;
+    pipe($child, $parent) or die;
+    my $pid = fork();
+    die "fork() failed: $!" unless defined $pid;
+    close($pid ? $child : $parent);
+    $pid;
+}
+
+if (pipe_to_fork('PARENT','CHILD')) {
+    # parent
+    print PARENT "pipe_to_fork\n";
+    close PARENT;
+}
+else {
+    # child
+    while (<CHILD>) { print; }
+    close CHILD;
+    exit;
+}
+
+sub pipe_from_fork ($$) {
+    my $parent = shift;
+    my $child = shift;
+    pipe($parent, $child) or die;
+    my $pid = fork();
+    die "fork() failed: $!" unless defined $pid;
+    close($pid ? $child : $parent);
+    $pid;
+}
+
+if (pipe_from_fork('PARENT','CHILD')) {
+    # parent
+    while (<PARENT>) { print; }
+    close PARENT;
+}
+else {
+    # child
+    print CHILD "pipe_from_fork\n";
+    close CHILD;
+    exit;
+}
+EXPECT
+pipe_from_fork
+pipe_to_fork
+########
+$|=1;
+if ($pid = fork()) {
+    print "forked first kid\n";
+    print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
+}
+else {
+    print "first child\n";
+    exit(0);
+}
+if ($pid = fork()) {
+    print "forked second kid\n";
+    print "wait() returned ok\n" if wait() == $pid;
+}
+else {
+    print "second child\n";
+    exit(0);
+}
+EXPECT
+forked first kid
+first child
+waitpid() returned ok
+forked second kid
+second child
+wait() returned ok
+########
+pipe(RDR,WTR) or die $!;
+my $pid = fork;
+die "fork: $!" if !defined $pid;
+if ($pid == 0) {
+    close RDR;
+    print WTR "STRING_FROM_CHILD\n";
+    close WTR;
+} else {
+    close WTR;
+    chomp(my $string_from_child  = <RDR>);
+    close RDR;
+    print $string_from_child eq "STRING_FROM_CHILD", "\n";
+}
+EXPECT
+1
+########
+# [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation
+sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2);
+EXPECT
+1
+1