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