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