Commit | Line | Data |
a43cb6b7 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | # Script to test auto flush on fork/exec/system/qx. The idea is to |
9 | # print "Pe" to a file from a parent process and "rl" to the same file |
10 | # from a child process. If buffers are flushed appropriately, the |
11 | # file should contain "Perl". We'll see... |
12 | use Config; |
13 | use warnings; |
14 | use strict; |
15 | |
16 | # This attempts to mirror the #ifdef forest found in perl.h so that we |
17 | # know when to run these tests. If that forest ever changes, change |
18 | # it here too or expect test gratuitous test failures. |
19 | if ($Config{useperlio} || $Config{fflushNULL} || $Config{d_sfio}) { |
20 | print "1..4\n"; |
21 | } else { |
22 | if ($Config{fflushall}) { |
23 | print "1..4\n"; |
24 | } else { |
25 | print "1..0 # Skip: fflush(NULL) or equivalent not available\n"; |
26 | exit; |
27 | } |
28 | } |
29 | |
30 | my $runperl = qq{$^X "-I../lib"}; |
31 | my @delete; |
32 | |
33 | END { |
34 | for (@delete) { |
35 | unlink $_ or warn "unlink $_: $!"; |
36 | } |
37 | } |
38 | |
39 | sub file_eq { |
40 | my $f = shift; |
41 | my $val = shift; |
42 | |
43 | open IN, $f or die "open $f: $!"; |
44 | chomp(my $line = <IN>); |
45 | close IN; |
46 | |
47 | print "# got $line\n"; |
48 | print "# expected $val\n"; |
49 | return $line eq $val; |
50 | } |
51 | |
52 | # This script will be used as the command to execute from |
53 | # child processes |
54 | open PROG, "> ff-prog" or die "open ff-prog: $!"; |
55 | print PROG <<'EOF'; |
56 | my $f = shift; |
57 | my $str = shift; |
58 | open OUT, ">> $f" or die "open $f: $!"; |
59 | print OUT $str; |
60 | close OUT; |
61 | EOF |
62 | ; |
63 | close PROG; |
64 | push @delete, "ff-prog"; |
65 | |
66 | $| = 0; # we want buffered output |
67 | |
68 | # Test flush on fork/exec |
69 | if ($Config{d_fork} ne "define") { |
70 | print "ok 1 # skipped: no fork\n"; |
71 | } else { |
72 | my $f = "ff-fork-$$"; |
73 | open OUT, "> $f" or die "open $f: $!"; |
74 | print OUT "Pe"; |
75 | my $pid = fork; |
76 | if ($pid) { |
77 | # Parent |
78 | wait; |
79 | close OUT or die "close $f: $!"; |
80 | } elsif (defined $pid) { |
81 | # Kid |
82 | print OUT "r"; |
83 | my $command = qq{$runperl "ff-prog" "$f" "l"}; |
84 | print "# $command\n"; |
85 | exec $command or die $!; |
86 | exit; |
87 | } else { |
88 | # Bang |
89 | die "fork: $!"; |
90 | } |
91 | |
92 | print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n"; |
93 | push @delete, $f; |
94 | } |
95 | |
96 | # Test flush on system/qx/pipe open |
97 | my %subs = ( |
98 | "system" => sub { |
99 | my $c = shift; |
100 | system $c; |
101 | }, |
102 | "qx" => sub { |
103 | my $c = shift; |
104 | qx{$c}; |
105 | }, |
106 | "popen" => sub { |
107 | my $c = shift; |
108 | open PIPE, "$c|" or die "$c: $!"; |
109 | close PIPE; |
110 | }, |
111 | ); |
112 | my $t = 2; |
113 | for (qw(system qx popen)) { |
114 | my $code = $subs{$_}; |
115 | my $f = "ff-$_-$$"; |
116 | my $command = qq{$runperl "ff-prog" "$f" "rl"}; |
117 | open OUT, "> $f" or die "open $f: $!"; |
118 | print OUT "Pe"; |
119 | print "# $command\n"; |
120 | $code->($command); |
121 | close OUT; |
122 | print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n"; |
123 | push @delete, $f; |
124 | ++$t; |
125 | } |