CVE-2013-7490: Improper Restriction of Operations within the Bounds of a Memory Buffer (CWE-119)
value: An issue was discovered in the DBI module before 1.632 for Perl. Using many arguments to methods for Callbacks may lead to memory corruption.
CWE description: The product performs operations on a memory buffer, but it reads from or writes to a memory location outside the buffer's intended boundary. This may result in read or write operations on unexpected memory locations that could be linked to other variables, data structures, or internal program data.
CVSS v3 base score: 5.3
Published: 2020-09-11T19:15Z
Repository: https://github.com/perl5-dbi/dbi
Language: Other
Files changed: Changes, DBI.xs, t/70callbacks.t
Commit date: 2014-09-21 15:01:17 +0100
Commit message: Fixed risk of memory corruption with many arguments to methods RT#86744

Diff: diff --git a/Changes b/Changes
index 849920d..7acf30f 100644
--- a/Changes
+++ b/Changes
@@ -6,10 +6,13 @@ DBI::Changes - List of significant changes to the DBI
 
 =cut
 
 =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
         driver_prefix is not fulfilled (RT#93204) [Jens Rehsack]
     Fixed redundant sprintf argument warning RT#97062 [Reini Urban]
diff --git a/DBI.xs b/DBI.xs
index c2c623f..9cb958a 100644
--- a/DBI.xs
+++ b/DBI.xs
@@ -3145,10 +3145,11 @@ dbi_profile_merge_nodes(SV *dest, SV *increment)
 
 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   */
     SV *st1 = ST(1);            /* used in debugging */
     SV *st2 = ST(2);            /* used in debugging */
@@ -3445,10 +3446,11 @@ XS(XS_DBI_dispatch)
                 if (sv_isobject(*hp)) { /* call DESTROY on the handle */
                     PUSHMARK(SP);
                     XPUSHs(*hp);
                     PUTBACK;
                     call_method("DESTROY", G_DISCARD|G_EVAL|G_KEEPERR);
+                    MSPAGAIN;
                 }
                 else {
                     imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ *hp, 0);
                     if (imp_xxh && DBIc_COMSET(imp_xxh)) {
                         dbih_clearcom(imp_xxh);
@@ -3537,12 +3539,12 @@ XS(XS_DBI_dispatch)
     ) {
         SV *orig_defsv;
         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
          */
         /* we want to localize $_ for the callback but can't just do that alone
@@ -3560,11 +3562,11 @@ XS(XS_DBI_dispatch)
         for (i=1; i < items; ++i) {     /* start at 1 to skip handle */
             PUSHs( ST(i) );
         }
         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);
         /* put $_ back now, but with an incremented ref count to compensate
          * for the ref count decrement that will happen when we exit the scope.
@@ -3888,11 +3890,11 @@ XS(XS_DBI_dispatch)
                 XPUSHs(h);
                 XPUSHs(sv_2mortal(newSVpv("AutoCommit",0)));
                 XPUSHs(&PL_sv_yes);
                 PUTBACK;
                 call_method("STORE", G_DISCARD);
-                SPAGAIN;
+                MSPAGAIN;
             }
         }
     }
 
     if (PL_tainting
@@ -4045,11 +4047,11 @@ XS(XS_DBI_dispatch)
             XPUSHs(msg);
             XPUSHs(sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh))));
             XPUSHs( result );
             PUTBACK;
             items = call_sv(*hook_svp, G_SCALAR);
-            SPAGAIN;
+            MSPAGAIN;
             status = (items) ? POPs : &PL_sv_undef;
             PUTBACK;
             if (trace_level)
                 PerlIO_printf(logfp,"    <- HandleError= %s%s%s%s\n",
                     neatsvpv(status,0),
diff --git a/t/70callbacks.t b/t/70callbacks.t
index cce00ae..463279d 100644
--- a/t/70callbacks.t
+++ b/t/70callbacks.t
@@ -219,10 +219,20 @@ is $sth->{Callbacks}, $sth_callbacks, "child Callbacks should be ChildCallbacks
 ok $sth->execute, 'Execute';
 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__
 
 A generic 'transparent' callback looks like this:

Vulnerable code:             PerlIO_printf(DBILOGFP, "%c   {{ %s callback %s being invoked\n",
                (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0));
        SPAGAIN;
                SPAGAIN;
            SPAGAIN;
Fixed code:     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.
    dORIGMARK;
                    MSPAGAIN;
            PerlIO_printf(DBILOGFP, "%c   {{ %s callback %s being invoked with %ld args\n",
                (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0), (long)items);
        MSPAGAIN;
                MSPAGAIN;
            MSPAGAIN;
# 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);