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