1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
7}
8
9plan tests => 32;
10
11# [perl #19566]: sv_gets writes directly to its argument via
12# TARG. Test that we respect SvREADONLY.
13use constant roref => \2;
14eval { for (roref) { $_ = <FH> } };
15like($@, 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)
28foreach 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
38foreach 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
47foreach 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
56foreach 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
64use strict;
65
66open F, '.' and binmode F and sysread F, $_, 1;
67my $err = $! + 0;
68close F;
69
70SKIP: {
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
86fresh_perl_is('BEGIN{<>}', '',
87              { switches => ['-w'], stdin => '', stderr => 1 },
88              'No ARGVOUT used only once warning');
89
90fresh_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.
97sub 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}
138SKIP: {
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
240my $obj = bless [];
241$obj .= <DATA>;
242like($obj, qr/main=ARRAY.*world/, 'rcatline and refs');
243
244# bug #38631
245require Tie::Scalar;
246tie our $one, 'Tie::StdScalar', "A: ";
247tie our $two, 'Tie::StdScalar', "B: ";
248my $junk = $one;
249$one .= <DATA>;
250$two .= <DATA>;
251is( $one, "A: One\n", "rcatline works with tied scalars" );
252is( $two, "B: Two\n", "rcatline works with tied scalars" );
253
254# mentioned in bug #97482
255# <$foo> versus readline($foo) should not affect vivification.
256my $yunk = "brumbo";
257if (exists $::{$yunk}) {
258     die "Name $yunk already used. Please adjust this test."
259}
260<$yunk>;
261ok !defined *$yunk, '<> does not autovivify';
262readline($yunk);
263ok !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.
267open *foom,'test.pl';
268my %f;
269$f{g} = *foom;
270readline $f{g};
271$f{g} = 3; # PL_last_in_gv should be cleared now
272is 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
274is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv';
275readline *{$f{g}};
276is 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.
280readline undef;
281is ${^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__
293moo
294moo
295 rules
296 rules
297world
298One
299Two
300