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