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($@, 'Modification of a read-only value attempted', '[perl #19566]');
19 my $file = tempfile();
20 open A,'+>',$file; $a = 3;
21 is($a .= <A>, 3, '#21628 - $a .= <A> , A eof');
23 is($a .= <A>, 4, '#21628 - $a .= <A> , A closed');
26 # [perl #21614]: 82 is chosen to exceed the length for sv_grow in
28 foreach my $k (1, 82) {
30 = runperl (stdin => '', stderr => 1,
31 prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)",
33 $result =~ s/\n\z// if $^O eq 'VMS';
34 is ($result, "end", '[perl #21614] for length ' . length('k' x $k));
38 foreach my $k (1, 21) {
40 = runperl (stdin => ' rules', stderr => 1,
41 prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}",
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));
47 foreach my $l (1, 82) {
52 is ($k, "moo\n", 'catline to COW sv for length ' . length $copy);
56 foreach my $l (1, 21) {
61 is ($k, "$perl rules\n", 'rcatline to COW sv for length ' . length $perl);
66 open F, '.' and sysread F, $_, 1;
71 skip "you can read directories as plain files", 2 unless( $err );
74 open F, '.' and $_=<F>;
75 ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' );
80 open F, '.' and $_=<F>;
81 ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' );
86 fresh_perl_is('BEGIN{<>}', '',
87 { switches => ['-w'], stdin => '', stderr => 1 },
88 'No ARGVOUT used only once warning');
90 fresh_perl_is('print readline', 'foo',
91 { switches => ['-w'], stdin => 'foo', stderr => 1 },
92 'readline() defaults to *ARGV');
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
97 sub test_eintr_readline {
98 my ( $fh, $timeout ) = @_;
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.
106 # Do a readline into $line.
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.
115 local $SIG{ALRM} = sub {
117 die 'abort this timeout';
121 $line = readline $fh;
126 # The code should have timed out.
127 if ( ! $timed_out ) {
130 : "Interrupted readline() test couldn't get interrupted: $errno";
134 $line = readline $fh;
140 # Connect two handles together.
148 skip( 2, 'The pipe function is unimplemented' );
151 # Make the pipe autoflushing
153 my $old_fh = select $out;
158 # Only one line is loaded into the pipe. It's written unbuffered
159 # so I'm confident it'll not be buffered.
160 syswrite $out, "once\n";
162 # Buggy perls will return the last thing successfully
163 # returned. Buggy perls will return "once\n" a second (and
164 # "infinitely" if we desired) as long as the internal read()
165 # syscall fails. In our case, it fails because the inner my($line)
166 # retains all its allocated space and buggy perl sets SvPOK to
167 # make the value valid but before it starts read().
168 my $once = test_eintr_readline( $in, 0 );
169 is( $once, "once\n", "readline read first line ok" );
173 todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
174 todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS';
175 $twice = test_eintr_readline( $in, 1 );
176 isnt( $twice, "once\n", "readline didn't re-return things when interrupted" );
180 todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
181 todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS';
182 local our $TODO = "bad readline returns '', not undef";
183 is( $twice, undef, "readline returned undef when interrupted" );
193 syswrite $out, "...\n";
194 $line .= readline $in;
196 is( $line, "ascii...\n", 'Appending from ascii to ascii' );
200 my $line = "\x{2080} utf8";
205 syswrite $out, "...\n";
206 $line .= readline $in;
208 is( $line, "\x{2080} utf8...\n", 'Appending from ascii to utf8' );
215 binmode $out, ':utf8';
216 binmode $in, ':utf8';
217 syswrite $out, "...\n";
218 $line .= readline $in;
220 is( $line, "ascii...\n", 'Appending from utf8 to ascii' );
224 my $line = "\x{2080} utf8";;
227 binmode $out, ':utf8';
228 binmode $in, ':utf8';
229 syswrite $out, "\x{2080}...\n";
230 $line .= readline $in;
232 is( $line, "\x{2080} utf8\x{2080}...\n", 'appending from utf to utf8' );
237 like($obj, qr/main=ARRAY.*world/, 'rcatline and refs');
241 tie our $one, 'Tie::StdScalar', "A: ";
242 tie our $two, 'Tie::StdScalar', "B: ";
246 is( $one, "A: One\n", "rcatline works with tied scalars" );
247 is( $two, "B: Two\n", "rcatline works with tied scalars" );
249 # mentioned in bug #97482
250 # <$foo> versus readline($foo) should not affect vivification.
252 if (exists $::{$yunk}) {
253 die "Name $yunk already used. Please adjust this test."
256 ok !defined *$yunk, '<> does not autovivify';
258 ok !defined *$yunk, "readline does not autovivify";
260 # [perl #97988] PL_last_in_gv could end up pointing to junk.
261 # Now glob copies set PL_last_in_gv to null when unglobbed.
262 open *foom,'test.pl';
266 $f{g} = 3; # PL_last_in_gv should be cleared now
267 is tell, -1, 'tell returns -1 after last gv is unglobbed';
268 $f{g} = *foom; # since PL_last_in_gv is null, this should have no effect
269 is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv';
271 is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv';