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