Skip to content
Permalink
Browse files Browse the repository at this point in the history
Fixed risk of memory corruption with many arguments to methods RT#86744
  • Loading branch information
timbunce committed Sep 21, 2014
1 parent cd6755f commit a8b98e9
Show file tree
Hide file tree
Showing 3 changed files with 20 additions and 5 deletions.
3 changes: 3 additions & 0 deletions Changes
Expand Up @@ -8,6 +8,9 @@ DBI::Changes - List of significant changes to the DBI

=head2 Changes in DBI 1.632

Fixed risk of memory corruption with many arguments to methods
originally reported by OSCHWALD for Callbacks but may apply
to other functionality in DBI method dispatch RT#86744.
Fixed DBD::PurePerl to not set $sth->{Active} true by default
drivers are expected to set it true as needed.
Fixed DBI::DBD::SqlEngine to complain loudly when prerequite
Expand Down
12 changes: 7 additions & 5 deletions DBI.xs
Expand Up @@ -3147,6 +3147,7 @@ XS(XS_DBI_dispatch); /* prototype to pass -Wmissing-prototypes */
XS(XS_DBI_dispatch)
{
dXSARGS;
dORIGMARK;
dMY_CXT;

SV *h = ST(0); /* the DBI handle we are working with */
Expand Down Expand Up @@ -3447,6 +3448,7 @@ XS(XS_DBI_dispatch)
XPUSHs(*hp);
PUTBACK;
call_method("DESTROY", G_DISCARD|G_EVAL|G_KEEPERR);
MSPAGAIN;
}
else {
imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ *hp, 0);
Expand Down Expand Up @@ -3539,8 +3541,8 @@ XS(XS_DBI_dispatch)
SV *code = SvRV(*hook_svp);
I32 skip_dispatch = 0;
if (trace_level)
PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked\n",
(PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0));
PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked with %ld args\n",
(PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0), (long)items);

/* we don't use ENTER,SAVETMPS & FREETMPS,LEAVE because we may need mortal
* results to live long enough to be returned to our caller
Expand All @@ -3562,7 +3564,7 @@ XS(XS_DBI_dispatch)
}
PUTBACK;
outitems = call_sv(code, G_ARRAY); /* call the callback code */
SPAGAIN;
MSPAGAIN;

/* The callback code can undef $_ to indicate to skip dispatch */
skip_dispatch = !SvOK(DEFSV);
Expand Down Expand Up @@ -3890,7 +3892,7 @@ XS(XS_DBI_dispatch)
XPUSHs(&PL_sv_yes);
PUTBACK;
call_method("STORE", G_DISCARD);
SPAGAIN;
MSPAGAIN;
}
}
}
Expand Down Expand Up @@ -4047,7 +4049,7 @@ XS(XS_DBI_dispatch)
XPUSHs( result );
PUTBACK;
items = call_sv(*hook_svp, G_SCALAR);
SPAGAIN;
MSPAGAIN;
status = (items) ? POPs : &PL_sv_undef;
PUTBACK;
if (trace_level)
Expand Down
10 changes: 10 additions & 0 deletions t/70callbacks.t
Expand Up @@ -221,6 +221,16 @@ is $called{execute}, 1, 'Execute callback should have been called';
ok $sth->fetch, 'Fetch';
is $called{fetch}, 1, 'Fetch callback should have been called';

# stress test for stack reallocation and mark handling -- RT#86744
my $stress_count = 3000;
my $place_holders = join(',', ('?') x $stress_count);
my @params = ('t') x $stress_count;
my $stress_dbh = DBI->connect( 'DBI:NullP:test');
my $stress_sth = $stress_dbh->prepare("select 1");
$stress_sth->{Callbacks}{execute} = sub { return; };
$stress_sth->execute(@params);


done_testing();

__END__
Expand Down

0 comments on commit a8b98e9

Please sign in to comment.