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