t/op/fork.t

   1 #!./perl
   2
   3 # tests for both real and emulated fork()
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     @INC = '../lib';
   8     require Config; import Config;
   9     unless ($Config{'d_fork'} or $Config{'d_pseudofork'}) {
  10         print "1..0 # Skip: no fork\n";
  11         exit 0;
  12     }
  13     $ENV{PERL5LIB} = "../lib";
  14 }
  15
  16 if ($^O eq 'mpeix') {
  17     print "1..0 # Skip: fork/status problems on MPE/iX\n";
  18     exit 0;
  19 }
  20
  21 $|=1;
  22
  23 undef $/;
  24 @prgs = split "\n########\n", <DATA>;
  25 print "1..", scalar @prgs, "\n";
  26
  27 $tmpfile = "forktmp000";
  28 1 while -f ++$tmpfile;
  29 END { close TEST; unlink $tmpfile if $tmpfile; }
  30
  31 $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat'));
  32
  33 for (@prgs){
  34     my $switch;
  35     if (s/^\s*(-\w.*)//){
  36         $switch = $1;
  37     }
  38     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  39     $expected =~ s/\n+$//;
  40     # results can be in any order, so sort 'em
  41     my @expected = sort split /\n/, $expected;
  42     open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
  43     print TEST $prog, "\n";
  44     close TEST or die "Cannot close $tmpfile: $!";
  45     my $results;
  46     if ($^O eq 'MSWin32') {
  47       $results = `.\\perl -I../lib $switch $tmpfile 2>&1`;
  48     }
  49     elsif ($^O eq 'NetWare') {
  50       $results = `perl -I../lib $switch $tmpfile 2>&1`;
  51     }
  52     else {
  53       $results = `./perl $switch $tmpfile 2>&1`;
  54     }
  55     $status = $?;
  56     $results =~ s/\n+$//;
  57     $results =~ s/at\s+forktmp\d+\s+line/at - line/g;
  58     $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g;
  59 # bison says 'parse error' instead of 'syntax error',
  60 # various yaccs may or may not capitalize 'syntax'.
  61     $results =~ s/^(syntax|parse) error/syntax error/mig;
  62     $results =~ s/^\n*Process terminated by SIG\w+\n?//mg
  63         if $^O eq 'os2';
  64     my @results = sort split /\n/, $results;
  65     if ( "@results" ne "@expected" ) {
  66         print STDERR "PROG: $switch\n$prog\n";
  67         print STDERR "EXPECTED:\n$expected\n";
  68         print STDERR "GOT:\n$results\n";
  69         print "not ";
  70     }
  71     print "ok ", ++$i, "\n";
  72 }
  73
  74 __END__
  75 $| = 1;
  76 if ($cid = fork) {
  77     sleep 1;
  78     if ($result = (kill 9, $cid)) {
  79         print "ok 2\n";
  80     }
  81     else {
  82         print "not ok 2 $result\n";
  83     }
  84     sleep 1 if $^O eq 'MSWin32';        # avoid WinNT race bug
  85 }
  86 else {
  87     print "ok 1\n";
  88     sleep 10;
  89 }
  90 EXPECT
  91 ok 1
  92 ok 2
  93 ########
  94 $| = 1;
  95 if ($cid = fork) {
  96     sleep 1;
  97     print "not " unless kill 'INT', $cid;
  98     print "ok 2\n";
  99 }
 100 else {
 101     # XXX On Windows the default signal handler kills the
 102     # XXX whole process, not just the thread (pseudo-process)
 103     $SIG{INT} = sub { exit };
 104     print "ok 1\n";
 105     sleep 5;
 106     die;
 107 }
 108 EXPECT
 109 ok 1
 110 ok 2
 111 ########
 112 $| = 1;
 113 sub forkit {
 114     print "iteration $i start\n";
 115     my $x = fork;
 116     if (defined $x) {
 117         if ($x) {
 118             print "iteration $i parent\n";
 119         }
 120         else {
 121             print "iteration $i child\n";
 122         }
 123     }
 124     else {
 125         print "pid $$ failed to fork\n";
 126     }
 127 }
 128 while ($i++ < 3) { do { forkit(); }; }
 129 EXPECT
 130 iteration 1 start
 131 iteration 1 parent
 132 iteration 1 child
 133 iteration 2 start
 134 iteration 2 parent
 135 iteration 2 child
 136 iteration 2 start
 137 iteration 2 parent
 138 iteration 2 child
 139 iteration 3 start
 140 iteration 3 parent
 141 iteration 3 child
 142 iteration 3 start
 143 iteration 3 parent
 144 iteration 3 child
 145 iteration 3 start
 146 iteration 3 parent
 147 iteration 3 child
 148 iteration 3 start
 149 iteration 3 parent
 150 iteration 3 child
 151 ########
 152 $| = 1;
 153 fork()
 154  ? (print("parent\n"),sleep(1))
 155  : (print("child\n"),exit) ;
 156 EXPECT
 157 parent
 158 child
 159 ########
 160 $| = 1;
 161 fork()
 162  ? (print("parent\n"),exit)
 163  : (print("child\n"),sleep(1)) ;
 164 EXPECT
 165 parent
 166 child
 167 ########
 168 $| = 1;
 169 @a = (1..3);
 170 for (@a) {
 171     if (fork) {
 172         print "parent $_\n";
 173         $_ = "[$_]";
 174     }
 175     else {
 176         print "child $_\n";
 177         $_ = "-$_-";
 178     }
 179 }
 180 print "@a\n";
 181 EXPECT
 182 parent 1
 183 child 1
 184 parent 2
 185 child 2
 186 parent 2
 187 child 2
 188 parent 3
 189 child 3
 190 parent 3
 191 child 3
 192 parent 3
 193 child 3
 194 parent 3
 195 child 3
 196 [1] [2] [3]
 197 -1- [2] [3]
 198 [1] -2- [3]
 199 [1] [2] -3-
 200 -1- -2- [3]
 201 -1- [2] -3-
 202 [1] -2- -3-
 203 -1- -2- -3-
 204 ########
 205 $| = 1;
 206 foreach my $c (1,2,3) {
 207     if (fork) {
 208         print "parent $c\n";
 209     }
 210     else {
 211         print "child $c\n";
 212         exit;
 213     }
 214 }
 215 while (wait() != -1) { print "waited\n" }
 216 EXPECT
 217 child 1
 218 child 2
 219 child 3
 220 parent 1
 221 parent 2
 222 parent 3
 223 waited
 224 waited
 225 waited
 226 ########
 227 use Config;
 228 $| = 1;
 229 $\ = "\n";
 230 fork()
 231  ? print($Config{osname} eq $^O)
 232  : print($Config{osname} eq $^O) ;
 233 EXPECT
 234 1
 235 1
 236 ########
 237 $| = 1;
 238 $\ = "\n";
 239 fork()
 240  ? do { require Config; print($Config::Config{osname} eq $^O); }
 241  : do { require Config; print($Config::Config{osname} eq $^O); }
 242 EXPECT
 243 1
 244 1
 245 ########
 246 $| = 1;
 247 use Cwd;
 248 $\ = "\n";
 249 my $dir;
 250 if (fork) {
 251     $dir = "f$$.tst";
 252     mkdir $dir, 0755;
 253     chdir $dir;
 254     print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
 255     chdir "..";
 256     rmdir $dir;
 257 }
 258 else {
 259     sleep 2;
 260     $dir = "f$$.tst";
 261     mkdir $dir, 0755;
 262     chdir $dir;
 263     print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
 264     chdir "..";
 265     rmdir $dir;
 266 }
 267 EXPECT
 268 ok 1 parent
 269 ok 1 child
 270 ########
 271 $| = 1;
 272 $\ = "\n";
 273 my $getenv;
 274 if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
 275     $getenv = qq[$^X -e "print \$ENV{TST}"];
 276 }
 277 else {
 278     $getenv = qq[$^X -e 'print \$ENV{TST}'];
 279 }
 280 $ENV{TST} = 'foo';
 281 if (fork) {
 282     sleep 1;
 283     print "parent before: " . `$getenv`;
 284     $ENV{TST} = 'bar';
 285     print "parent after: " . `$getenv`;
 286 }
 287 else {
 288     print "child before: " . `$getenv`;
 289     $ENV{TST} = 'baz';
 290     print "child after: " . `$getenv`;
 291 }
 292 EXPECT
 293 child before: foo
 294 child after: baz
 295 parent before: foo
 296 parent after: bar
 297 ########
 298 $| = 1;
 299 $\ = "\n";
 300 if ($pid = fork) {
 301     waitpid($pid,0);
 302     print "parent got $?"
 303 }
 304 else {
 305     exit(42);
 306 }
 307 EXPECT
 308 parent got 10752
 309 ########
 310 $| = 1;
 311 $\ = "\n";
 312 my $echo = 'echo';
 313 if ($pid = fork) {
 314     waitpid($pid,0);
 315     print "parent got $?"
 316 }
 317 else {
 318     exec("$echo foo");
 319 }
 320 EXPECT
 321 foo
 322 parent got 0
 323 ########
 324 if (fork) {
 325     die "parent died";
 326 }
 327 else {
 328     die "child died";
 329 }
 330 EXPECT
 331 parent died at - line 2.
 332 child died at - line 5.
 333 ########
 334 if ($pid = fork) {
 335     eval { die "parent died" };
 336     print $@;
 337 }
 338 else {
 339     eval { die "child died" };
 340     print $@;
 341 }
 342 EXPECT
 343 parent died at - line 2.
 344 child died at - line 6.
 345 ########
 346 if (eval q{$pid = fork}) {
 347     eval q{ die "parent died" };
 348     print $@;
 349 }
 350 else {
 351     eval q{ die "child died" };
 352     print $@;
 353 }
 354 EXPECT
 355 parent died at (eval 2) line 1.
 356 child died at (eval 2) line 1.
 357 ########
 358 BEGIN {
 359     $| = 1;
 360     fork and exit;
 361     print "inner\n";
 362 }
 363 # XXX In emulated fork(), the child will not execute anything after
 364 # the BEGIN block, due to difficulties in recreating the parse stacks
 365 # and restarting yyparse() midstream in the child.  This can potentially
 366 # be overcome by treating what's after the BEGIN{} as a brand new parse.
 367 #print "outer\n"
 368 EXPECT
 369 inner
 370 ########
 371 sub pipe_to_fork ($$) {
 372     my $parent = shift;
 373     my $child = shift;
 374     pipe($child, $parent) or die;
 375     my $pid = fork();
 376     die "fork() failed: $!" unless defined $pid;
 377     close($pid ? $child : $parent);
 378     $pid;
 379 }
 380
 381 if (pipe_to_fork('PARENT','CHILD')) {
 382     # parent
 383     print PARENT "pipe_to_fork\n";
 384     close PARENT;
 385 }
 386 else {
 387     # child
 388     while (<CHILD>) { print; }
 389     close CHILD;
 390     exit;
 391 }
 392
 393 sub pipe_from_fork ($$) {
 394     my $parent = shift;
 395     my $child = shift;
 396     pipe($parent, $child) or die;
 397     my $pid = fork();
 398     die "fork() failed: $!" unless defined $pid;
 399     close($pid ? $child : $parent);
 400     $pid;
 401 }
 402
 403 if (pipe_from_fork('PARENT','CHILD')) {
 404     # parent
 405     while (<PARENT>) { print; }
 406     close PARENT;
 407 }
 408 else {
 409     # child
 410     print CHILD "pipe_from_fork\n";
 411     close CHILD;
 412     exit;
 413 }
 414 EXPECT
 415 pipe_from_fork
 416 pipe_to_fork
 417 ########
 418 $|=1;
 419 if ($pid = fork()) {
 420     print "forked first kid\n";
 421     print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
 422 }
 423 else {
 424     print "first child\n";
 425     exit(0);
 426 }
 427 if ($pid = fork()) {
 428     print "forked second kid\n";
 429     print "wait() returned ok\n" if wait() == $pid;
 430 }
 431 else {
 432     print "second child\n";
 433     exit(0);
 434 }
 435 EXPECT
 436 forked first kid
 437 first child
 438 waitpid() returned ok
 439 forked second kid
 440 second child
 441 wait() returned ok
 442 ########
 443 pipe(RDR,WTR) or die $!;
 444 my $pid = fork;
 445 die "fork: $!" if !defined $pid;
 446 if ($pid == 0) {
 447     my $rand_child = rand;
 448     close RDR;
 449     print WTR $rand_child, "\n";
 450     close WTR;
 451 } else {
 452     my $rand_parent = rand;
 453     close WTR;
 454     chomp(my $rand_child  = <RDR>);
 455     close RDR;
 456     print $rand_child ne $rand_parent, "\n";
 457 }
 458 EXPECT
 459 1
 460 ########
 461 # [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation
 462 sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2);
 463 EXPECT
 464 1
 465 1