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