Fixed risk of memory corruption with many arguments to methods RT#86744

Author: timbunce

Changes

@@ -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

DBI.xs

@@ -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   */
@@ -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);
@@ -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
@@ -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);
@@ -3890,7 +3892,7 @@ XS(XS_DBI_dispatch)
                 XPUSHs(&PL_sv_yes);
                 PUTBACK;
                 call_method("STORE", G_DISCARD);
-                SPAGAIN;
+                MSPAGAIN;
             }
         }
     }
@@ -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)

t/70callbacks.t

@@ -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__