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