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     require './test.pl';
  15 }
  16
  17 if ($^O eq 'mpeix') {
  18     print "1..0 # Skip: fork/status problems on MPE/iX\n";
  19     exit 0;
  20 }
  21
  22 $|=1;
  23
  24 undef $/;
  25 @prgs = split "\n########\n", <DATA>;
  26 print "1..", scalar @prgs, "\n";
  27
  28 $tmpfile = tempfile();
  29 END { close TEST }
  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+$::tempfile_regexp\s+line/at - line/g;
  58     $results =~ s/of\s+$::tempfile_regexp\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 my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works.
 249 $\ = "\n";
 250 my $dir;
 251 if (fork) {
 252     $dir = "f$$.tst";
 253     mkdir $dir, 0755;
 254     chdir $dir;
 255     print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
 256     chdir "..";
 257     rmdir $dir;
 258 }
 259 else {
 260     sleep 2;
 261     $dir = "f$$.tst";
 262     mkdir $dir, 0755;
 263     chdir $dir;
 264     print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
 265     chdir "..";
 266     rmdir $dir;
 267 }
 268 EXPECT
 269 ok 1 parent
 270 ok 1 child
 271 ########
 272 $| = 1;
 273 $\ = "\n";
 274 my $getenv;
 275 if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
 276     $getenv = qq[$^X -e "print \$ENV{TST}"];
 277 }
 278 else {
 279     $getenv = qq[$^X -e 'print \$ENV{TST}'];
 280 }
 281 $ENV{TST} = 'foo';
 282 if (fork) {
 283     sleep 1;
 284     print "parent before: " . `$getenv`;
 285     $ENV{TST} = 'bar';
 286     print "parent after: " . `$getenv`;
 287 }
 288 else {
 289     print "child before: " . `$getenv`;
 290     $ENV{TST} = 'baz';
 291     print "child after: " . `$getenv`;
 292 }
 293 EXPECT
 294 child before: foo
 295 child after: baz
 296 parent before: foo
 297 parent after: bar
 298 ########
 299 $| = 1;
 300 $\ = "\n";
 301 if ($pid = fork) {
 302     waitpid($pid,0);
 303     print "parent got $?"
 304 }
 305 else {
 306     exit(42);
 307 }
 308 EXPECT
 309 parent got 10752
 310 ########
 311 $| = 1;
 312 $\ = "\n";
 313 my $echo = 'echo';
 314 if ($pid = fork) {
 315     waitpid($pid,0);
 316     print "parent got $?"
 317 }
 318 else {
 319     exec("$echo foo");
 320 }
 321 EXPECT
 322 foo
 323 parent got 0
 324 ########
 325 if (fork) {
 326     die "parent died";
 327 }
 328 else {
 329     die "child died";
 330 }
 331 EXPECT
 332 parent died at - line 2.
 333 child died at - line 5.
 334 ########
 335 if ($pid = fork) {
 336     eval { die "parent died" };
 337     print $@;
 338 }
 339 else {
 340     eval { die "child died" };
 341     print $@;
 342 }
 343 EXPECT
 344 parent died at - line 2.
 345 child died at - line 6.
 346 ########
 347 if (eval q{$pid = fork}) {
 348     eval q{ die "parent died" };
 349     print $@;
 350 }
 351 else {
 352     eval q{ die "child died" };
 353     print $@;
 354 }
 355 EXPECT
 356 parent died at (eval 2) line 1.
 357 child died at (eval 2) line 1.
 358 ########
 359 BEGIN {
 360     $| = 1;
 361     fork and exit;
 362     print "inner\n";
 363 }
 364 # XXX In emulated fork(), the child will not execute anything after
 365 # the BEGIN block, due to difficulties in recreating the parse stacks
 366 # and restarting yyparse() midstream in the child.  This can potentially
 367 # be overcome by treating what's after the BEGIN{} as a brand new parse.
 368 #print "outer\n"
 369 EXPECT
 370 inner
 371 ########
 372 sub pipe_to_fork ($$) {
 373     my $parent = shift;
 374     my $child = shift;
 375     pipe($child, $parent) or die;
 376     my $pid = fork();
 377     die "fork() failed: $!" unless defined $pid;
 378     close($pid ? $child : $parent);
 379     $pid;
 380 }
 381
 382 if (pipe_to_fork('PARENT','CHILD')) {
 383     # parent
 384     print PARENT "pipe_to_fork\n";
 385     close PARENT;
 386 }
 387 else {
 388     # child
 389     while (<CHILD>) { print; }
 390     close CHILD;
 391     exit;
 392 }
 393
 394 sub pipe_from_fork ($$) {
 395     my $parent = shift;
 396     my $child = shift;
 397     pipe($parent, $child) or die;
 398     my $pid = fork();
 399     die "fork() failed: $!" unless defined $pid;
 400     close($pid ? $child : $parent);
 401     $pid;
 402 }
 403
 404 if (pipe_from_fork('PARENT','CHILD')) {
 405     # parent
 406     while (<PARENT>) { print; }
 407     close PARENT;
 408 }
 409 else {
 410     # child
 411     print CHILD "pipe_from_fork\n";
 412     close CHILD;
 413     exit;
 414 }
 415 EXPECT
 416 pipe_from_fork
 417 pipe_to_fork
 418 ########
 419 $|=1;
 420 if ($pid = fork()) {
 421     print "forked first kid\n";
 422     print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
 423 }
 424 else {
 425     print "first child\n";
 426     exit(0);
 427 }
 428 if ($pid = fork()) {
 429     print "forked second kid\n";
 430     print "wait() returned ok\n" if wait() == $pid;
 431 }
 432 else {
 433     print "second child\n";
 434     exit(0);
 435 }
 436 EXPECT
 437 forked first kid
 438 first child
 439 waitpid() returned ok
 440 forked second kid
 441 second child
 442 wait() returned ok
 443 ########
 444 pipe(RDR,WTR) or die $!;
 445 my $pid = fork;
 446 die "fork: $!" if !defined $pid;
 447 if ($pid == 0) {
 448     close RDR;
 449     print WTR "STRING_FROM_CHILD\n";
 450     close WTR;
 451 } else {
 452     close WTR;
 453     chomp(my $string_from_child  = <RDR>);
 454     close RDR;
 455     print $string_from_child eq "STRING_FROM_CHILD", "\n";
 456 }
 457 EXPECT
 458 1
 459 ########
 460 # [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation
 461 sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2);
 462 EXPECT
 463 1
 464 1