Commit | Line | Data |
---|---|---|
a43cb6b7 BS |
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. | |
375927eb PK |
19 | my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0; |
20 | my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0; | |
21 | my $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0; | |
22 | my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0; | |
23 | my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0; | |
24 | ||
25 | if ($useperlio || $fflushNULL || $d_sfio) { | |
a43cb6b7 BS |
26 | print "1..4\n"; |
27 | } else { | |
375927eb | 28 | if ($fflushall) { |
a43cb6b7 BS |
29 | print "1..4\n"; |
30 | } else { | |
31 | print "1..0 # Skip: fflush(NULL) or equivalent not available\n"; | |
32 | exit; | |
33 | } | |
34 | } | |
35 | ||
36 | my $runperl = qq{$^X "-I../lib"}; | |
37 | my @delete; | |
38 | ||
39 | END { | |
40 | for (@delete) { | |
41 | unlink $_ or warn "unlink $_: $!"; | |
42 | } | |
43 | } | |
44 | ||
45 | sub file_eq { | |
46 | my $f = shift; | |
47 | my $val = shift; | |
48 | ||
49 | open IN, $f or die "open $f: $!"; | |
50 | chomp(my $line = <IN>); | |
51 | close IN; | |
52 | ||
53 | print "# got $line\n"; | |
54 | print "# expected $val\n"; | |
55 | return $line eq $val; | |
56 | } | |
57 | ||
58 | # This script will be used as the command to execute from | |
59 | # child processes | |
60 | open PROG, "> ff-prog" or die "open ff-prog: $!"; | |
61 | print PROG <<'EOF'; | |
62 | my $f = shift; | |
63 | my $str = shift; | |
64 | open OUT, ">> $f" or die "open $f: $!"; | |
65 | print OUT $str; | |
66 | close OUT; | |
67 | EOF | |
68 | ; | |
69 | close PROG; | |
70 | push @delete, "ff-prog"; | |
71 | ||
72 | $| = 0; # we want buffered output | |
73 | ||
74 | # Test flush on fork/exec | |
375927eb | 75 | if (!$d_fork) { |
a43cb6b7 BS |
76 | print "ok 1 # skipped: no fork\n"; |
77 | } else { | |
78 | my $f = "ff-fork-$$"; | |
79 | open OUT, "> $f" or die "open $f: $!"; | |
80 | print OUT "Pe"; | |
81 | my $pid = fork; | |
82 | if ($pid) { | |
83 | # Parent | |
84 | wait; | |
85 | close OUT or die "close $f: $!"; | |
86 | } elsif (defined $pid) { | |
87 | # Kid | |
88 | print OUT "r"; | |
89 | my $command = qq{$runperl "ff-prog" "$f" "l"}; | |
90 | print "# $command\n"; | |
91 | exec $command or die $!; | |
92 | exit; | |
93 | } else { | |
94 | # Bang | |
95 | die "fork: $!"; | |
96 | } | |
97 | ||
98 | print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n"; | |
99 | push @delete, $f; | |
100 | } | |
101 | ||
102 | # Test flush on system/qx/pipe open | |
103 | my %subs = ( | |
104 | "system" => sub { | |
105 | my $c = shift; | |
106 | system $c; | |
107 | }, | |
108 | "qx" => sub { | |
109 | my $c = shift; | |
110 | qx{$c}; | |
111 | }, | |
112 | "popen" => sub { | |
113 | my $c = shift; | |
114 | open PIPE, "$c|" or die "$c: $!"; | |
115 | close PIPE; | |
116 | }, | |
117 | ); | |
118 | my $t = 2; | |
119 | for (qw(system qx popen)) { | |
120 | my $code = $subs{$_}; | |
121 | my $f = "ff-$_-$$"; | |
122 | my $command = qq{$runperl "ff-prog" "$f" "rl"}; | |
123 | open OUT, "> $f" or die "open $f: $!"; | |
124 | print OUT "Pe"; | |
a3d14d6a | 125 | close OUT; |
a43cb6b7 BS |
126 | print "# $command\n"; |
127 | $code->($command); | |
a43cb6b7 BS |
128 | print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n"; |
129 | push @delete, $f; | |
130 | ++$t; | |
131 | } |