In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/fd2c61bcfdb4c097be4d3934b00729bb46787824?hp=8e43ec2a83e92726f8f1ba38f6dab4a1d7b231d6>
- Log -----------------------------------------------------------------
commit fd2c61bcfdb4c097be4d3934b00729bb46787824
Author: Josh ben Jore <jj...@cpan.org>
Date: Tue Jul 13 23:57:14 2010 -0700
[perl #72729] Test that sv_gets doesn't revive dead strings
M t/op/readline.t
commit 5b88351f7cdb2869b27557a7b14d688598019402
Author: Josh ben Jore <jj...@cpan.org>
Date: Tue Jul 13 23:56:29 2010 -0700
Add t/op/readline.t docs
M t/op/readline.t
commit f72e8700d8f634d185a0ab589cfaf62386cd6a21
Author: Josh ben Jore <jj...@cpan.org>
Date: Tue Jul 13 21:33:34 2010 -0700
Add x-ref from call site in do_readline() of sv_grow() to it's matching
test in t/op/readline.t
M pp_hot.c
-----------------------------------------------------------------------
Summary of changes:
pp_hot.c | 8 +++-
t/op/readline.t | 92 +++++++++++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 96 insertions(+), 4 deletions(-)
diff --git a/pp_hot.c b/pp_hot.c
index 6f48d5a..217ee26 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1639,8 +1639,12 @@ Perl_do_readline(pTHX)
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen && !SvREADONLY(sv))
- Sv_Grow(sv, 80); /* try short-buffering it */
+ if (!tmplen && !SvREADONLY(sv)) {
+ /* try short-buffering it. Please update t/op/readline.t
+ * if you change the growth length.
+ */
+ Sv_Grow(sv, 80);
+ }
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
diff --git a/t/op/readline.t b/t/op/readline.t
index 1069a97..74fcafc 100644
--- a/t/op/readline.t
+++ b/t/op/readline.t
@@ -6,11 +6,14 @@ BEGIN {
require './test.pl';
}
-plan tests => 18;
+plan tests => 20;
+# [perl #19566]: sv_gets writes directly to its argument via
+# TARG. Test that we respect SvREADONLY.
eval { for (\2) { $_ = <FH> } };
like($@, 'Modification of a read-only value attempted', '[perl #19566]');
+# [perl #21628]
{
my $file = tempfile();
open A,'+>',$file; $a = 3;
@@ -19,7 +22,8 @@ like($@, 'Modification of a read-only value attempted',
'[perl #19566]');
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,
@@ -87,6 +91,90 @@ fresh_perl_is('print readline', 'foo',
{ 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 );
+ my $twice = test_eintr_readline( $in, 1 );
+ is( $once, "once\n", "readline read first line ok" );
+
+ TODO: {
+ local our $TODO = "bad readline returns '', not undef";
+ is( $twice, undef, "readline didn't return first line again" );
+ }
+}
+
my $obj = bless [];
$obj .= <DATA>;
like($obj, qr/main=ARRAY.*world/, 'rcatline and refs');
--
Perl5 Master Repository
