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
CommitLineData
79628082
SM
1#!./perl
2
3BEGIN {
4 chdir 't';
79628082 5 require './test.pl';
d6211870
FC
6 @INC = () unless is_miniperl();
7 unshift @INC, '../lib';
79628082
SM
8}
9
b73e5385 10plan tests => 30;
79628082 11
5b88351f
JJ
12# [perl #19566]: sv_gets writes directly to its argument via
13# TARG. Test that we respect SvREADONLY.
2484f8db
FC
14use constant roref => \2;
15eval { for (roref) { $_ = <FH> } };
aaa63dae 16like($@, qr/Modification of a read-only value attempted/, '[perl #19566]');
79628082 17
5b88351f 18# [perl #21628]
ba92458f 19{
1c25d394
NC
20 my $file = tempfile();
21 open A,'+>',$file; $a = 3;
ba92458f
AE
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');
ba92458f 25}
10bcdfd6 26
5b88351f
JJ
27# [perl #21614]: 82 is chosen to exceed the length for sv_grow in
28# do_readline (80)
bfe0b846 29foreach my $k (1, 82) {
10bcdfd6 30 my $result
048e6480 31 = runperl (stdin => '', stderr => 1,
bfe0b846 32 prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)",
10bcdfd6 33 );
bfe0b846
CB
34 $result =~ s/\n\z// if $^O eq 'VMS';
35 is ($result, "end", '[perl #21614] for length ' . length('k' x $k));
10bcdfd6 36}
bc44a8a2
NC
37
38
bfe0b846 39foreach my $k (1, 21) {
bc44a8a2 40 my $result
048e6480 41 = runperl (stdin => ' rules', stderr => 1,
bfe0b846 42 prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}",
bc44a8a2 43 );
bfe0b846
CB
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));
bc44a8a2
NC
46}
47
48foreach 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
57foreach 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}
2d726892
TF
64
65use strict;
2d726892 66
519ecd2c 67open F, '.' and sysread F, $_, 1;
2d726892
TF
68my $err = $! + 0;
69close F;
70
71SKIP: {
389edf24 72 skip "you can read directories as plain files", 2 unless( $err );
2d726892
TF
73
74 $!=0;
519ecd2c 75 open F, '.' and $_=<F>;
2d726892
TF
76 ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' );
77 close F;
78
79 $!=0;
80 { local $/;
519ecd2c 81 open F, '.' and $_=<F>;
2d726892
TF
82 ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' );
83 close F;
84 }
85}
86
7b8203e3
YST
87fresh_perl_is('BEGIN{<>}', '',
88 { switches => ['-w'], stdin => '', stderr => 1 },
89 'No ARGVOUT used only once warning');
90
e4b7ebf3
RGS
91fresh_perl_is('print readline', 'foo',
92 { switches => ['-w'], stdin => 'foo', stderr => 1 },
93 'readline() defaults to *ARGV');
94
fd2c61bc
JJ
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.
98sub 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}
139SKIP: {
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 );
7a0f0843 170 is( $once, "once\n", "readline read first line ok" );
fd2c61bc 171
23fe4d6e 172 my $twice;
fd2c61bc 173 TODO: {
4a8201af 174 todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
23fe4d6e
CB
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: {
4a8201af 181 todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
23fe4d6e 182 todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS';
fd2c61bc 183 local our $TODO = "bad readline returns '', not undef";
7a0f0843 184 is( $twice, undef, "readline returned undef when interrupted" );
fd2c61bc
JJ
185 }
186}
187
4e86d350
JJ
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
48de12d9
RGS
236my $obj = bless [];
237$obj .= <DATA>;
238like($obj, qr/main=ARRAY.*world/, 'rcatline and refs');
239
0f722b55
RGS
240# bug #38631
241require Tie::Scalar;
242tie our $one, 'Tie::StdScalar', "A: ";
243tie our $two, 'Tie::StdScalar', "B: ";
244my $junk = $one;
245$one .= <DATA>;
246$two .= <DATA>;
247is( $one, "A: One\n", "rcatline works with tied scalars" );
248is( $two, "B: Two\n", "rcatline works with tied scalars" );
249
e59953eb
FC
250# mentioned in bug #97482
251# <$foo> versus readline($foo) should not affect vivification.
252my $yunk = "brumbo";
253if (exists $::{$yunk}) {
254 die "Name $yunk already used. Please adjust this test."
255}
256<$yunk>;
257ok !defined *$yunk, '<> does not autovivify';
258readline($yunk);
259ok !defined *$yunk, "readline does not autovivify";
260
69930016
FC
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.
263open *foom,'test.pl';
264my %f;
265$f{g} = *foom;
266readline $f{g};
267$f{g} = 3; # PL_last_in_gv should be cleared now
268is 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
270is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv';
b73e5385
FC
271readline *{$f{g}};
272is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv';
69930016 273
bc44a8a2
NC
274__DATA__
275moo
276moo
277 rules
278 rules
48de12d9 279world
0f722b55
RGS
280One
281Two