require './test.pl';
}
-plan tests => 18;
+plan tests => 30;
-eval { for (\2) { $_ = <FH> } };
-like($@, 'Modification of a read-only value attempted', '[perl #19566]');
+# [perl #19566]: sv_gets writes directly to its argument via
+# TARG. Test that we respect SvREADONLY.
+use constant roref => \2;
+eval { for (roref) { $_ = <FH> } };
+like($@, qr/Modification of a read-only value attempted/, '[perl #19566]');
+# [perl #21628]
{
my $file = tempfile();
open A,'+>',$file; $a = 3;
is($a .= <A>, 4, '#21628 - $a .= <A> , A closed');
}
-# 82 is chosen to exceed the length for sv_grow in do_readline (80)
+# [perl #21614]: 82 is chosen to exceed the length for sv_grow in
+# do_readline (80)
foreach my $k (1, 82) {
my $result
= runperl (stdin => '', stderr => 1,
}
use strict;
-use File::Spec;
-open F, File::Spec->curdir and sysread F, $_, 1;
+open F, '.' and sysread F, $_, 1;
my $err = $! + 0;
close F;
skip "you can read directories as plain files", 2 unless( $err );
$!=0;
- open F, File::Spec->curdir and $_=<F>;
+ open F, '.' and $_=<F>;
ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' );
close F;
$!=0;
{ local $/;
- open F, File::Spec->curdir and $_=<F>;
+ open F, '.' and $_=<F>;
ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' );
close F;
}
{ switches => ['-w'], stdin => 'foo', stderr => 1 },
'readline() defaults to *ARGV');
+# [perl #72720] Test that sv_gets clears any variables that should be
+# empty so if the read() aborts with EINTER, the TARG is actually
+# cleared.
+sub test_eintr_readline {
+ my ( $fh, $timeout ) = @_;
+
+ # This variable, the TARG for the readline is the core of this
+ # test. The test is to see that after a my() and a failure in
+ # readline() has the variable revived old, "dead" values from the
+ # past or is it still undef like expected.
+ my $line;
+
+ # Do a readline into $line.
+ if ( $timeout ) {
+
+ # Do a SIGALARM aborted readline(). The underlying sv_gets()
+ # from sv.c will use the syscall read() while will exit early
+ # and return something like EINTR or ERESTARTSYS.
+ my $timed_out;
+ my $errno;
+ eval {
+ local $SIG{ALRM} = sub {
+ $timed_out = 1;
+ die 'abort this timeout';
+ };
+ alarm $timeout;
+ undef $!;
+ $line = readline $fh;
+ $errno = $!;
+ alarm 0;
+ };
+
+ # The code should have timed out.
+ if ( ! $timed_out ) {
+ warn $@
+ ? "$@: $errno\n"
+ : "Interrupted readline() test couldn't get interrupted: $errno";
+ }
+ }
+ else {
+ $line = readline $fh;
+ }
+ return $line;
+}
+SKIP: {
+
+ # Connect two handles together.
+ my ( $in, $out );
+ my $piped;
+ eval {
+ pipe $in, $out;
+ $piped = 1;
+ };
+ if ( ! $piped ) {
+ skip( 2, 'The pipe function is unimplemented' );
+ }
+
+ # Make the pipe autoflushing
+ {
+ my $old_fh = select $out;
+ $| = 1;
+ select $old_fh;
+ }
+
+ # Only one line is loaded into the pipe. It's written unbuffered
+ # so I'm confident it'll not be buffered.
+ syswrite $out, "once\n";
+
+ # Buggy perls will return the last thing successfully
+ # returned. Buggy perls will return "once\n" a second (and
+ # "infinitely" if we desired) as long as the internal read()
+ # syscall fails. In our case, it fails because the inner my($line)
+ # retains all its allocated space and buggy perl sets SvPOK to
+ # make the value valid but before it starts read().
+ my $once = test_eintr_readline( $in, 0 );
+ is( $once, "once\n", "readline read first line ok" );
+
+ my $twice;
+ TODO: {
+ todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
+ todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS';
+ $twice = test_eintr_readline( $in, 1 );
+ isnt( $twice, "once\n", "readline didn't re-return things when interrupted" );
+ }
+
+ TODO: {
+ todo_skip( 'alarm() on Windows does not interrupt system calls' ) if $^O eq 'MSWin32';
+ todo_skip( 'readline not interrupted by alarm on VMS -- why?' ) if $^O eq 'VMS';
+ local our $TODO = "bad readline returns '', not undef";
+ is( $twice, undef, "readline returned undef when interrupted" );
+ }
+}
+
+{
+ my $line = 'ascii';
+ my ( $in, $out );
+ pipe $in, $out;
+ binmode $in;
+ binmode $out;
+ syswrite $out, "...\n";
+ $line .= readline $in;
+
+ is( $line, "ascii...\n", 'Appending from ascii to ascii' );
+}
+
+{
+ my $line = "\x{2080} utf8";
+ my ( $in, $out );
+ pipe $in, $out;
+ binmode $out;
+ binmode $in;
+ syswrite $out, "...\n";
+ $line .= readline $in;
+
+ is( $line, "\x{2080} utf8...\n", 'Appending from ascii to utf8' );
+}
+
+{
+ my $line = 'ascii';
+ my ( $in, $out );
+ pipe $in, $out;
+ binmode $out, ':utf8';
+ binmode $in, ':utf8';
+ syswrite $out, "...\n";
+ $line .= readline $in;
+
+ is( $line, "ascii...\n", 'Appending from utf8 to ascii' );
+}
+
+{
+ my $line = "\x{2080} utf8";;
+ my ( $in, $out );
+ pipe $in, $out;
+ binmode $out, ':utf8';
+ binmode $in, ':utf8';
+ syswrite $out, "\x{2080}...\n";
+ $line .= readline $in;
+
+ is( $line, "\x{2080} utf8\x{2080}...\n", 'appending from utf to utf8' );
+}
+
my $obj = bless [];
$obj .= <DATA>;
like($obj, qr/main=ARRAY.*world/, 'rcatline and refs');
is( $one, "A: One\n", "rcatline works with tied scalars" );
is( $two, "B: Two\n", "rcatline works with tied scalars" );
+# mentioned in bug #97482
+# <$foo> versus readline($foo) should not affect vivification.
+my $yunk = "brumbo";
+if (exists $::{$yunk}) {
+ die "Name $yunk already used. Please adjust this test."
+}
+<$yunk>;
+ok !defined *$yunk, '<> does not autovivify';
+readline($yunk);
+ok !defined *$yunk, "readline does not autovivify";
+
+# [perl #97988] PL_last_in_gv could end up pointing to junk.
+# Now glob copies set PL_last_in_gv to null when unglobbed.
+open *foom,'test.pl';
+my %f;
+$f{g} = *foom;
+readline $f{g};
+$f{g} = 3; # PL_last_in_gv should be cleared now
+is tell, -1, 'tell returns -1 after last gv is unglobbed';
+$f{g} = *foom; # since PL_last_in_gv is null, this should have no effect
+is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv';
+readline *{$f{g}};
+is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv';
+
__DATA__
moo
moo
https://perl5.git.perl.org / perl5.git / blobdiff