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