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     require './test.pl';
   8     set_up_inc('../lib');
   9     require Config;
  10     skip_all('no fork')
  11         unless ($Config::Config{d_fork} or $Config::Config{d_pseudofork});
  12     skip_all('no fork')
  13         if $^O eq 'MSWin32' && is_miniperl;
  14 }
  15
  16 $|=1;
  17
  18 run_multiple_progs('', \*DATA);
  19
  20 my $shell = $ENV{SHELL} || '';
  21 SKIP: {
  22     skip "This test can only be run under bash or zsh"
  23         unless $shell =~ m{/(?:ba|z)sh$};
  24     my $probe = qx{
  25         $shell -c 'ulimit -u 1 2>/dev/null && echo good'
  26     };
  27     chomp $probe;
  28     skip "Can't set ulimit -u on this system: $probe"
  29         unless $probe eq 'good';
  30
  31     my $out = qx{
  32         $shell -c 'ulimit -u 1; exec $^X -e "
  33             print((() = fork) == 1 ? q[ok] : q[not ok])
  34         "'
  35     };
  36     # perl #117141
  37     skip "fork() didn't fail, maybe you're running as root", 1
  38       if $out eq "okok";
  39     is($out, "ok", "bash/zsh-only test for 'fork' returning undef on failure");
  40 }
  41
  42 done_testing();
  43
  44 __END__
  45 $| = 1;
  46 if ($cid = fork) {
  47     sleep 1;
  48     if ($result = (kill 9, $cid)) {
  49         print "ok 2\n";
  50     }
  51     else {
  52         print "not ok 2 $result\n";
  53     }
  54     sleep 1 if $^O eq 'MSWin32';        # avoid WinNT race bug
  55 }
  56 else {
  57     print "ok 1\n";
  58     sleep 10;
  59 }
  60 EXPECT
  61 OPTION random
  62 ok 1
  63 ok 2
  64 ########
  65 $| = 1;
  66 if ($cid = fork) {
  67     sleep 1;
  68     print "not " unless kill 'INT', $cid;
  69     print "ok 2\n";
  70 }
  71 else {
  72     # XXX On Windows the default signal handler kills the
  73     # XXX whole process, not just the thread (pseudo-process)
  74     $SIG{INT} = sub { exit };
  75     print "ok 1\n";
  76     sleep 5;
  77     die;
  78 }
  79 EXPECT
  80 OPTION random
  81 ok 1
  82 ok 2
  83 ########
  84 $| = 1;
  85 sub forkit {
  86     print "iteration $i start\n";
  87     my $x = fork;
  88     if (defined $x) {
  89         if ($x) {
  90             print "iteration $i parent\n";
  91         }
  92         else {
  93             print "iteration $i child\n";
  94         }
  95     }
  96     else {
  97         print "pid $$ failed to fork\n";
  98     }
  99 }
 100 while ($i++ < 3) { do { forkit(); }; }
 101 EXPECT
 102 OPTION random
 103 iteration 1 start
 104 iteration 1 parent
 105 iteration 1 child
 106 iteration 2 start
 107 iteration 2 parent
 108 iteration 2 child
 109 iteration 2 start
 110 iteration 2 parent
 111 iteration 2 child
 112 iteration 3 start
 113 iteration 3 parent
 114 iteration 3 child
 115 iteration 3 start
 116 iteration 3 parent
 117 iteration 3 child
 118 iteration 3 start
 119 iteration 3 parent
 120 iteration 3 child
 121 iteration 3 start
 122 iteration 3 parent
 123 iteration 3 child
 124 ########
 125 $| = 1;
 126 fork()
 127  ? (print("parent\n"),sleep(1))
 128  : (print("child\n"),exit) ;
 129 EXPECT
 130 OPTION random
 131 parent
 132 child
 133 ########
 134 $| = 1;
 135 fork()
 136  ? (print("parent\n"),exit)
 137  : (print("child\n"),sleep(1)) ;
 138 EXPECT
 139 OPTION random
 140 parent
 141 child
 142 ########
 143 $| = 1;
 144 @a = (1..3);
 145 for (@a) {
 146     if (fork) {
 147         print "parent $_\n";
 148         $_ = "[$_]";
 149     }
 150     else {
 151         print "child $_\n";
 152         $_ = "-$_-";
 153     }
 154 }
 155 print "@a\n";
 156 EXPECT
 157 OPTION random
 158 parent 1
 159 child 1
 160 parent 2
 161 child 2
 162 parent 2
 163 child 2
 164 parent 3
 165 child 3
 166 parent 3
 167 child 3
 168 parent 3
 169 child 3
 170 parent 3
 171 child 3
 172 [1] [2] [3]
 173 -1- [2] [3]
 174 [1] -2- [3]
 175 [1] [2] -3-
 176 -1- -2- [3]
 177 -1- [2] -3-
 178 [1] -2- -3-
 179 -1- -2- -3-
 180 ########
 181 $| = 1;
 182 foreach my $c (1,2,3) {
 183     if (fork) {
 184         print "parent $c\n";
 185     }
 186     else {
 187         print "child $c\n";
 188         exit;
 189     }
 190 }
 191 while (wait() != -1) { print "waited\n" }
 192 EXPECT
 193 OPTION random
 194 child 1
 195 child 2
 196 child 3
 197 parent 1
 198 parent 2
 199 parent 3
 200 waited
 201 waited
 202 waited
 203 ########
 204 use Config;
 205 $| = 1;
 206 $\ = "\n";
 207 fork()
 208  ? print($Config{osname} eq $^O)
 209  : print($Config{osname} eq $^O) ;
 210 EXPECT
 211 OPTION random
 212 1
 213 1
 214 ########
 215 $| = 1;
 216 $\ = "\n";
 217 fork()
 218  ? do { require Config; print($Config::Config{osname} eq $^O); }
 219  : do { require Config; print($Config::Config{osname} eq $^O); }
 220 EXPECT
 221 OPTION random
 222 1
 223 1
 224 ########
 225 $| = 1;
 226 use Cwd;
 227 my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works.
 228 $\ = "\n";
 229 my $dir;
 230 if (fork) {
 231     $dir = "f$$.tst";
 232     mkdir $dir, 0755;
 233     chdir $dir;
 234     print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
 235     chdir "..";
 236     rmdir $dir;
 237 }
 238 else {
 239     sleep 2;
 240     $dir = "f$$.tst";
 241     mkdir $dir, 0755;
 242     chdir $dir;
 243     print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
 244     chdir "..";
 245     rmdir $dir;
 246 }
 247 EXPECT
 248 OPTION random
 249 ok 1 parent
 250 ok 1 child
 251 ########
 252 $| = 1;
 253 $\ = "\n";
 254 my $getenv;
 255 if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
 256     $getenv = qq[$^X -e "print \$ENV{TST}"];
 257 }
 258 else {
 259     $getenv = qq[$^X -e 'print \$ENV{TST}'];
 260 }
 261 $ENV{TST} = 'foo';
 262 if (fork) {
 263     sleep 1;
 264     print "parent before: " . `$getenv`;
 265     $ENV{TST} = 'bar';
 266     print "parent after: " . `$getenv`;
 267 }
 268 else {
 269     print "child before: " . `$getenv`;
 270     $ENV{TST} = 'baz';
 271     print "child after: " . `$getenv`;
 272 }
 273 EXPECT
 274 OPTION random
 275 child before: foo
 276 child after: baz
 277 parent before: foo
 278 parent after: bar
 279 ########
 280 $| = 1;
 281 $\ = "\n";
 282 if ($pid = fork) {
 283     waitpid($pid,0);
 284     print "parent got $?"
 285 }
 286 else {
 287     exit(42);
 288 }
 289 EXPECT
 290 OPTION random
 291 parent got 10752
 292 ########
 293 $| = 1;
 294 $\ = "\n";
 295 my $echo = 'echo';
 296 if ($^O =~ /android/) {
 297     $echo = q{sh -c 'echo $@' -- };
 298 }
 299 if ($pid = fork) {
 300     waitpid($pid,0);
 301     print "parent got $?"
 302 }
 303 else {
 304     exec("$echo foo");
 305 }
 306 EXPECT
 307 OPTION random
 308 foo
 309 parent got 0
 310 ########
 311 if (fork) {
 312     die "parent died";
 313 }
 314 else {
 315     die "child died";
 316 }
 317 EXPECT
 318 OPTION random
 319 parent died at - line 2.
 320 child died at - line 5.
 321 ########
 322 if ($pid = fork) {
 323     eval { die "parent died" };
 324     print $@;
 325 }
 326 else {
 327     eval { die "child died" };
 328     print $@;
 329 }
 330 EXPECT
 331 OPTION random
 332 parent died at - line 2.
 333 child died at - line 6.
 334 ########
 335 if (eval q{$pid = fork}) {
 336     eval q{ die "parent died" };
 337     print $@;
 338 }
 339 else {
 340     eval q{ die "child died" };
 341     print $@;
 342 }
 343 EXPECT
 344 OPTION random
 345 parent died at (eval 2) line 1.
 346 child died at (eval 2) line 1.
 347 ########
 348 BEGIN {
 349     $| = 1;
 350     fork and exit;
 351     print "inner\n";
 352 }
 353 # XXX In emulated fork(), the child will not execute anything after
 354 # the BEGIN block, due to difficulties in recreating the parse stacks
 355 # and restarting yyparse() midstream in the child.  This can potentially
 356 # be overcome by treating what's after the BEGIN{} as a brand new parse.
 357 #print "outer\n"
 358 EXPECT
 359 OPTION random
 360 inner
 361 ########
 362 sub pipe_to_fork ($$) {
 363     my $parent = shift;
 364     my $child = shift;
 365     pipe($child, $parent) or die;
 366     my $pid = fork();
 367     die "fork() failed: $!" unless defined $pid;
 368     close($pid ? $child : $parent);
 369     $pid;
 370 }
 371
 372 if (pipe_to_fork('PARENT','CHILD')) {
 373     # parent
 374     print PARENT "pipe_to_fork\n";
 375     close PARENT;
 376 }
 377 else {
 378     # child
 379     while (<CHILD>) { print; }
 380     close CHILD;
 381     exit;
 382 }
 383
 384 sub pipe_from_fork ($$) {
 385     my $parent = shift;
 386     my $child = shift;
 387     pipe($parent, $child) or die;
 388     my $pid = fork();
 389     die "fork() failed: $!" unless defined $pid;
 390     close($pid ? $child : $parent);
 391     $pid;
 392 }
 393
 394 if (pipe_from_fork('PARENT','CHILD')) {
 395     # parent
 396     while (<PARENT>) { print; }
 397     close PARENT;
 398 }
 399 else {
 400     # child
 401     print CHILD "pipe_from_fork\n";
 402     close CHILD;
 403     exit;
 404 }
 405 EXPECT
 406 OPTION random
 407 pipe_from_fork
 408 pipe_to_fork
 409 ########
 410 $|=1;
 411 if ($pid = fork()) {
 412     print "forked first kid\n";
 413     print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
 414 }
 415 else {
 416     print "first child\n";
 417     exit(0);
 418 }
 419 if ($pid = fork()) {
 420     print "forked second kid\n";
 421     print "wait() returned ok\n" if wait() == $pid;
 422 }
 423 else {
 424     print "second child\n";
 425     exit(0);
 426 }
 427 EXPECT
 428 OPTION random
 429 forked first kid
 430 first child
 431 waitpid() returned ok
 432 forked second kid
 433 second child
 434 wait() returned ok
 435 ########
 436 pipe(RDR,WTR) or die $!;
 437 my $pid = fork;
 438 die "fork: $!" if !defined $pid;
 439 if ($pid == 0) {
 440     close RDR;
 441     print WTR "STRING_FROM_CHILD\n";
 442     close WTR;
 443 } else {
 444     close WTR;
 445     chomp(my $string_from_child  = <RDR>);
 446     close RDR;
 447     print $string_from_child eq "STRING_FROM_CHILD", "\n";
 448 }
 449 EXPECT
 450 OPTION random
 451 1
 452 ########
 453 # [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation
 454 sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2);
 455 EXPECT
 456 OPTION random
 457 1
 458 1
 459 ########
 460 # [perl #72604] @DB::args stops working across Win32 fork
 461 $|=1;
 462 sub f {
 463     if ($pid = fork()) {
 464         print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
 465     }
 466     else {
 467         package DB;
 468         my @c = caller(0);
 469         print "child: called as [$c[3](", join(',',@DB::args), ")]\n";
 470         exit(0);
 471     }
 472 }
 473 f("foo", "bar");
 474 EXPECT
 475 OPTION random
 476 child: called as [main::f(foo,bar)]
 477 waitpid() returned ok
 478 ########
 479 # Windows 2000: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
 480 system $^X,  "-e", "if (\$pid=fork){sleep 1;kill(9, \$pid)} else {sleep 5}";
 481 print $?>>8, "\n";
 482 EXPECT
 483 0
 484 ########
 485 # Windows 7: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
 486 system $^X,  "-e", "if (\$pid=fork){kill(9, \$pid)} else {sleep 5}";
 487 print $?>>8, "\n";
 488 EXPECT
 489 0
 490 ########
 491 # Windows fork() emulation: can we still waitpid() after signalling SIGTERM?
 492 $|=1;
 493 if (my $pid = fork) {
 494     sleep 1;
 495     print "1\n";
 496     kill 'TERM', $pid;
 497     waitpid($pid, 0);
 498     print "4\n";
 499 }
 500 else {
 501     $SIG{TERM} = sub { print "2\n" };
 502     sleep 10;
 503     print "3\n";
 504 }
 505 EXPECT
 506 1
 507 2
 508 3
 509 4
 510 ########
 511 # this used to SEGV. RT # 121721
 512 $|=1;
 513 &main;
 514 sub main {
 515     if (my $pid = fork) {
 516         waitpid($pid, 0);
 517     }
 518     else {
 519         print "foo\n";
 520     }
 521 }
 522 EXPECT
 523 foo
 524 ########
 525 # ${^GLOBAL_PHASE} at the end of a pseudo-fork
 526 if (my $pid = fork) {
 527     waitpid $pid, 0;
 528 } else {
 529     eval 'END { print "${^GLOBAL_PHASE}\n" }';
 530     exit;
 531 }
 532 EXPECT
 533 END