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 sub forkit {
 101     print "iteration $i start\n";
 102     my $x = fork;
 103     if (defined $x) {
 104         if ($x) {
 105             print "iteration $i parent\n";
 106         }
 107         else {
 108             print "iteration $i child\n";
 109         }
 110     }
 111     else {
 112         print "pid $$ failed to fork\n";
 113     }
 114 }
 115 while ($i++ < 3) { do { forkit(); }; }
 116 EXPECT
 117 iteration 1 start
 118 iteration 1 parent
 119 iteration 1 child
 120 iteration 2 start
 121 iteration 2 parent
 122 iteration 2 child
 123 iteration 2 start
 124 iteration 2 parent
 125 iteration 2 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 iteration 3 start
 136 iteration 3 parent
 137 iteration 3 child
 138 ########
 139 $| = 1;
 140 fork()
 141  ? (print("parent\n"),sleep(1))
 142  : (print("child\n"),exit) ;
 143 EXPECT
 144 parent
 145 child
 146 ########
 147 $| = 1;
 148 fork()
 149  ? (print("parent\n"),exit)
 150  : (print("child\n"),sleep(1)) ;
 151 EXPECT
 152 parent
 153 child
 154 ########
 155 $| = 1;
 156 @a = (1..3);
 157 for (@a) {
 158     if (fork) {
 159         print "parent $_\n";
 160         $_ = "[$_]";
 161     }
 162     else {
 163         print "child $_\n";
 164         $_ = "-$_-";
 165     }
 166 }
 167 print "@a\n";
 168 EXPECT
 169 parent 1
 170 child 1
 171 parent 2
 172 child 2
 173 parent 2
 174 child 2
 175 parent 3
 176 child 3
 177 parent 3
 178 child 3
 179 parent 3
 180 child 3
 181 parent 3
 182 child 3
 183 [1] [2] [3]
 184 -1- [2] [3]
 185 [1] -2- [3]
 186 [1] [2] -3-
 187 -1- -2- [3]
 188 -1- [2] -3-
 189 [1] -2- -3-
 190 -1- -2- -3-
 191 ########
 192 $| = 1;
 193 foreach my $c (1,2,3) {
 194     if (fork) {
 195         print "parent $c\n";
 196     }
 197     else {
 198         print "child $c\n";
 199         exit;
 200     }
 201 }
 202 while (wait() != -1) { print "waited\n" }
 203 EXPECT
 204 child 1
 205 child 2
 206 child 3
 207 parent 1
 208 parent 2
 209 parent 3
 210 waited
 211 waited
 212 waited
 213 ########
 214 use Config;
 215 $| = 1;
 216 $\ = "\n";
 217 fork()
 218  ? print($Config{osname} eq $^O)
 219  : print($Config{osname} eq $^O) ;
 220 EXPECT
 221 1
 222 1
 223 ########
 224 $| = 1;
 225 $\ = "\n";
 226 fork()
 227  ? do { require Config; print($Config::Config{osname} eq $^O); }
 228  : do { require Config; print($Config::Config{osname} eq $^O); }
 229 EXPECT
 230 1
 231 1
 232 ########
 233 $| = 1;
 234 use Cwd;
 235 $\ = "\n";
 236 my $dir;
 237 if (fork) {
 238     $dir = "f$$.tst";
 239     mkdir $dir, 0755;
 240     chdir $dir;
 241     print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
 242     chdir "..";
 243     rmdir $dir;
 244 }
 245 else {
 246     sleep 2;
 247     $dir = "f$$.tst";
 248     mkdir $dir, 0755;
 249     chdir $dir;
 250     print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
 251     chdir "..";
 252     rmdir $dir;
 253 }
 254 EXPECT
 255 ok 1 parent
 256 ok 1 child
 257 ########
 258 $| = 1;
 259 $\ = "\n";
 260 my $getenv;
 261 if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
 262     $getenv = qq[$^X -e "print \$ENV{TST}"];
 263 }
 264 else {
 265     $getenv = qq[$^X -e 'print \$ENV{TST}'];
 266 }
 267 $ENV{TST} = 'foo';
 268 if (fork) {
 269     sleep 1;
 270     print "parent before: " . `$getenv`;
 271     $ENV{TST} = 'bar';
 272     print "parent after: " . `$getenv`;
 273 }
 274 else {
 275     print "child before: " . `$getenv`;
 276     $ENV{TST} = 'baz';
 277     print "child after: " . `$getenv`;
 278 }
 279 EXPECT
 280 child before: foo
 281 child after: baz
 282 parent before: foo
 283 parent after: bar
 284 ########
 285 $| = 1;
 286 $\ = "\n";
 287 if ($pid = fork) {
 288     waitpid($pid,0);
 289     print "parent got $?"
 290 }
 291 else {
 292     exit(42);
 293 }
 294 EXPECT
 295 parent got 10752
 296 ########
 297 $| = 1;
 298 $\ = "\n";
 299 my $echo = 'echo';
 300 if ($pid = fork) {
 301     waitpid($pid,0);
 302     print "parent got $?"
 303 }
 304 else {
 305     exec("$echo foo");
 306 }
 307 EXPECT
 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 parent died at - line 2.
 319 child died at - line 5.
 320 ########
 321 if ($pid = fork) {
 322     eval { die "parent died" };
 323     print $@;
 324 }
 325 else {
 326     eval { die "child died" };
 327     print $@;
 328 }
 329 EXPECT
 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 parent died at (eval 2) line 1.
 343 child died at (eval 2) line 1.
 344 ########
 345 BEGIN {
 346     $| = 1;
 347     fork and exit;
 348     print "inner\n";
 349 }
 350 # XXX In emulated fork(), the child will not execute anything after
 351 # the BEGIN block, due to difficulties in recreating the parse stacks
 352 # and restarting yyparse() midstream in the child.  This can potentially
 353 # be overcome by treating what's after the BEGIN{} as a brand new parse.
 354 #print "outer\n"
 355 EXPECT
 356 inner
 357 ########
 358 sub pipe_to_fork ($$) {
 359     my $parent = shift;
 360     my $child = shift;
 361     pipe($child, $parent) or die;
 362     my $pid = fork();
 363     die "fork() failed: $!" unless defined $pid;
 364     close($pid ? $child : $parent);
 365     $pid;
 366 }
 367
 368 if (pipe_to_fork('PARENT','CHILD')) {
 369     # parent
 370     print PARENT "pipe_to_fork\n";
 371     close PARENT;
 372 }
 373 else {
 374     # child
 375     while (<CHILD>) { print; }
 376     close CHILD;
 377     exit;
 378 }
 379
 380 sub pipe_from_fork ($$) {
 381     my $parent = shift;
 382     my $child = shift;
 383     pipe($parent, $child) or die;
 384     my $pid = fork();
 385     die "fork() failed: $!" unless defined $pid;
 386     close($pid ? $child : $parent);
 387     $pid;
 388 }
 389
 390 if (pipe_from_fork('PARENT','CHILD')) {
 391     # parent
 392     while (<PARENT>) { print; }
 393     close PARENT;
 394 }
 395 else {
 396     # child
 397     print CHILD "pipe_from_fork\n";
 398     close CHILD;
 399     exit;
 400 }
 401 EXPECT
 402 pipe_from_fork
 403 pipe_to_fork
 404 ########
 405 $|=1;
 406 if ($pid = fork()) {
 407     print "forked first kid\n";
 408     print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
 409 }
 410 else {
 411     print "first child\n";
 412     exit(0);
 413 }
 414 if ($pid = fork()) {
 415     print "forked second kid\n";
 416     print "wait() returned ok\n" if wait() == $pid;
 417 }
 418 else {
 419     print "second child\n";
 420     exit(0);
 421 }
 422 EXPECT
 423 forked first kid
 424 first child
 425 waitpid() returned ok
 426 forked second kid
 427 second child
 428 wait() returned ok