File perl-DBI-CVE-2013-7490.patch of Package perl-DBI.16626

From a8b98e988d6ea2946f5f56691d6d5ead53f65766 Mon Sep 17 00:00:00 2001
From: Tim Bunce <Tim.Bunce@pobox.com>
Date: Sun, 21 Sep 2014 15:01:17 +0100
Subject: [PATCH] Fixed risk of memory corruption with many arguments to
 methods RT#86744

---
 DBI.xs          | 12 +++++++-----
 t/70callbacks.t | 10 ++++++++++
 3 files changed, 20 insertions(+), 5 deletions(-)

Index: DBI-1.628/DBI.xs
===================================================================
--- DBI-1.628.orig/DBI.xs
+++ DBI-1.628/DBI.xs
@@ -3117,6 +3117,7 @@ XS(XS_DBI_dispatch);            /* proto
 XS(XS_DBI_dispatch)
 {
     dXSARGS;
+    dORIGMARK;
     dMY_CXT;
 
     SV *h   = ST(0);            /* the DBI handle we are working with   */
@@ -3417,6 +3418,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);
@@ -3507,8 +3509,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
@@ -3530,7 +3532,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);
@@ -3854,7 +3856,7 @@ XS(XS_DBI_dispatch)
                 XPUSHs(&PL_sv_yes);
                 PUTBACK;
                 call_method("STORE", G_DISCARD);
-                SPAGAIN;
+                MSPAGAIN;
             }
         }
     }
@@ -4011,7 +4013,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)
Index: DBI-1.628/t/70callbacks.t
===================================================================
--- DBI-1.628.orig/t/70callbacks.t
+++ DBI-1.628/t/70callbacks.t
@@ -190,6 +190,17 @@ is $called{execute}, 1, 'Execute callbac
 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: