This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Get readline.t working under minitest
[perl5.git] / t / op / readline.t
1 #!./perl
2
3 BEGIN {
4     chdir 't';
5     require './test.pl';
6     @INC = () unless is_miniperl();
7     unshift @INC, '../lib';
8 }
9
10 plan tests => 30;
11
12 # [perl #19566]: sv_gets writes directly to its argument via
13 # TARG. Test that we respect SvREADONLY.
14 use constant roref => \2;
15 eval { for (roref) { $_ = <FH> } };
16 like($@, qr/Modification of a read-only value attempted/, '[perl #19566]');
17
18 # [perl #21628]
19 {
20   my $file = tempfile();
21   open A,'+>',$file; $a = 3;
22   is($a .= <A>, 3, '#21628 - $a .= <A> , A eof');
23   close A; $a = 4;
24   is($a .= <A>, 4, '#21628 - $a .= <A> , A closed');
25 }
26
27 # [perl #21614]: 82 is chosen to exceed the length for sv_grow in
28 # do_readline (80)
29 foreach my $k (1, 82) {
30   my $result
31     = runperl (stdin => '', stderr => 1,
32               prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)",
33               );
34   $result =~ s/\n\z// if $^O eq 'VMS';
35   is ($result, "end", '[perl #21614] for length ' . length('k' x $k));
36 }
37
38
39 foreach my $k (1, 21) {
40   my $result
41     = runperl (stdin => ' rules', stderr => 1,
42               prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}",
43               );
44   $result =~ s/\n\z// if $^O eq 'VMS';
45   is ($result, ('perl' x $k) . " rules", 'rcatline to shared sv for length ' . length('perl' x $k));
46 }
47
48 foreach my $l (1, 82) {
49   my $k = $l;
50   $k = 'k' x $k;
51   my $copy = $k;
52   $k = <DATA>;
53   is ($k, "moo\n", 'catline to COW sv for length ' . length $copy);
54 }
55
56
57 foreach my $l (1, 21) {
58   my $k = $l;
59   $k = 'perl' x $k;
60   my $perl = $k;
61   $k .= <DATA>;
62   is ($k, "$perl rules\n", 'rcatline to COW sv for length ' . length $perl);
63 }
64
65 use strict;
66
67 open F, '.' and sysread F, $_, 1;
68 my $err = $! + 0;
69 close F;
70
71 SKIP: {
72   skip "you can read directories as plain files", 2 unless( $err );
73
74   $!=0;
75   open F, '.' and $_=<F>;
76   ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' );
77   close F;
78
79   $!=0;
80   { local $/;
81     open F, '.' and $_=<F>;
82     ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' );
83     close F;
84   }
85 }
86
87 fresh_perl_is('BEGIN{<>}', '',
88               { switches => ['-w'], stdin => '', stderr => 1 },
89               'No ARGVOUT used only once warning');
90
91 fresh_perl_is('print readline', 'foo',
92               { switches => ['-w'], stdin => 'foo', stderr => 1 },
93               'readline() defaults to *ARGV');
94
95 # [perl #72720] Test that sv_gets clears any variables that should be
96 # empty so if the read() aborts with EINTER, the TARG is actually
97 # cleared.
98 sub test_eintr_readline {
99     my ( $fh, $timeout ) = @_;
100
101     # This variable, the TARG for the readline is the core of this
102     # test. The test is to see that after a my() and a failure in
103     # readline() has the variable revived old, "dead" values from the
104     # past or is it still undef like expected.
105     my $line;
106
107     # Do a readline into $line.
108     if ( $timeout ) {
109
110         # Do a SIGALARM aborted readline(). The underlying sv_gets()
111         # from sv.c will use the syscall read() while will exit early
112         # and return something like EINTR or ERESTARTSYS.
113         my $timed_out;
114         my $errno;
115         eval {
116             local $SIG{ALRM} = sub {
117                 $timed_out = 1;
118                 die 'abort this timeout';
119             };
120             alarm $timeout;
121             undef $!;
122             $line = readline $fh;
123             $errno = $!;
124             alarm 0;
125         };
126
127         # The code should have timed out.
128         if ( ! $timed_out ) {
129             warn $@
130                 ? "$@: $errno\n"
131                 : "Interrupted readline() test couldn't get interrupted: $errno";
132         }
133     }
134     else {
135         $line = readline $fh;
136     }
137     return $line;
138 }
139 SKIP: {
140
141     # Connect two handles together.
142     my ( $in, $out );
143     my $piped;
144     eval {
145         pipe $in, $out;
146         $piped = 1;
147     };
148     if ( ! $piped ) {
149         skip( 2, 'The pipe function is unimplemented' );
150     }
151
152     # Make the pipe autoflushing
153     {
154         my $old_fh = select $out;
155         $| = 1;
156         select $old_fh;
157     }
158
159     # Only one line is loaded into the pipe. It's written unbuffered
160     # so I'm confident it'll not be buffered.
161     syswrite $out, "once\n";
162
163     # Buggy perls will return the last thing successfully
164     # returned. Buggy perls will return "once\n" a second (and
165     # "infinitely" if we desired) as long as the internal read()
166     # syscall fails. In our case, it fails because the inner my($line)
167     # retains all its allocated space and buggy perl sets SvPOK to
168     # make the value valid but before it starts read().
169     my $once  = test_eintr_readline( $in, 0 );
170     is(   $once,  "once\n", "readline read first line ok" );
171
172     my $twice;
173     TODO: {
174         todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
175         todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS';
176         $twice = test_eintr_readline( $in, 1 );
177         isnt( $twice, "once\n", "readline didn't re-return things when interrupted" );
178     }
179
180     TODO: {
181         todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
182         todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS';
183         local our $TODO = "bad readline returns '', not undef";
184         is( $twice, undef, "readline returned undef when interrupted" );
185     }
186 }
187
188 {
189     my $line = 'ascii';
190     my ( $in, $out );
191     pipe $in, $out;
192     binmode $in;
193     binmode $out;
194     syswrite $out, "...\n";
195     $line .= readline $in;
196
197     is( $line, "ascii...\n", 'Appending from ascii to ascii' );
198 }
199
200 {
201     my $line = "\x{2080} utf8";
202     my ( $in, $out );
203     pipe $in, $out;
204     binmode $out;
205     binmode $in;
206     syswrite $out, "...\n";
207     $line .= readline $in;
208
209     is( $line, "\x{2080} utf8...\n", 'Appending from ascii to utf8' );
210 }
211
212 {
213     my $line = 'ascii';
214     my ( $in, $out );
215     pipe $in, $out;
216     binmode $out, ':utf8';
217     binmode $in,  ':utf8';
218     syswrite $out, "...\n";
219     $line .= readline $in;
220
221     is( $line, "ascii...\n", 'Appending from utf8 to ascii' );
222 }
223
224 {
225     my $line = "\x{2080} utf8";;
226     my ( $in, $out );
227     pipe $in, $out;
228     binmode $out, ':utf8';
229     binmode $in,  ':utf8';
230     syswrite $out, "\x{2080}...\n";
231     $line .= readline $in;
232
233     is( $line, "\x{2080} utf8\x{2080}...\n", 'appending from utf to utf8' );
234 }
235
236 my $obj = bless [];
237 $obj .= <DATA>;
238 like($obj, qr/main=ARRAY.*world/, 'rcatline and refs');
239
240 # bug #38631
241 require Tie::Scalar;
242 tie our $one, 'Tie::StdScalar', "A: ";
243 tie our $two, 'Tie::StdScalar', "B: ";
244 my $junk = $one;
245 $one .= <DATA>;
246 $two .= <DATA>;
247 is( $one, "A: One\n", "rcatline works with tied scalars" );
248 is( $two, "B: Two\n", "rcatline works with tied scalars" );
249
250 # mentioned in bug #97482
251 # <$foo> versus readline($foo) should not affect vivification.
252 my $yunk = "brumbo";
253 if (exists $::{$yunk}) {
254      die "Name $yunk already used. Please adjust this test."
255 }
256 <$yunk>;
257 ok !defined *$yunk, '<> does not autovivify';
258 readline($yunk);
259 ok !defined *$yunk, "readline does not autovivify";
260
261 # [perl #97988] PL_last_in_gv could end up pointing to junk.
262 #               Now glob copies set PL_last_in_gv to null when unglobbed.
263 open *foom,'test.pl';
264 my %f;
265 $f{g} = *foom;
266 readline $f{g};
267 $f{g} = 3; # PL_last_in_gv should be cleared now
268 is tell, -1, 'tell returns -1 after last gv is unglobbed';
269 $f{g} = *foom; # since PL_last_in_gv is null, this should have no effect
270 is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv';
271 readline *{$f{g}};
272 is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv';
273
274 __DATA__
275 moo
276 moo
277  rules
278  rules
279 world
280 One
281 Two