Upgrade Devel::PPPort from 3.24 to 3.25

8 files changed, 220 insertions, 12 deletions

diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 75cb6c1f3b..65c7f89063 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -342,7 +342,7 @@ use File::Glob qw(:case);
     },
 
     'Devel::PPPort' => {
-        'DISTRIBUTION' => 'WOLFSAGE/Devel-PPPort-3.24.tar.gz',
+        'DISTRIBUTION' => 'WOLFSAGE/Devel-PPPort-3.25.tar.gz',
         # RJBS has asked MHX to have UPSTREAM be 'blead'
         # (i.e. move this from cpan/ to dist/)
         'FILES'        => q[cpan/Devel-PPPort],
diff --git a/cpan/Devel-PPPort/PPPort_pm.PL b/cpan/Devel-PPPort/PPPort_pm.PL
index a73336cd25..d96593bd19 100644
--- a/cpan/Devel-PPPort/PPPort_pm.PL
+++ b/cpan/Devel-PPPort/PPPort_pm.PL
@@ -539,7 +539,7 @@ package Devel::PPPort;
 use strict;
 use vars qw($VERSION $data);
 
-$VERSION = '3.24';
+$VERSION = '3.25';
 
 sub _init_data
 {
diff --git a/cpan/Devel-PPPort/parts/inc/SvPV b/cpan/Devel-PPPort/parts/inc/SvPV
index 1034072514..387b0d8401 100644
--- a/cpan/Devel-PPPort/parts/inc/SvPV
+++ b/cpan/Devel-PPPort/parts/inc/SvPV
@@ -438,7 +438,6 @@ SvPV_nomg_nolen(sv)
         SV *sv
         PREINIT:
                 char *str;
-                STRLEN len;
         CODE:
                 str = SvPV_nomg_nolen(sv);
                 RETVAL = strEQ(str, "mhx") ? 61 : 0;
diff --git a/cpan/Devel-PPPort/parts/inc/cop b/cpan/Devel-PPPort/parts/inc/cop
index 72d80878d8..355a2e1aad 100644
--- a/cpan/Devel-PPPort/parts/inc/cop
+++ b/cpan/Devel-PPPort/parts/inc/cop
@@ -11,6 +11,7 @@
 
 =provides
 
+caller_cx
 __UNDEFINED__
 
 =implementation
@@ -46,6 +47,81 @@ __UNDEFINED__  CopSTASH_eq(c,hv)        (CopSTASH(c) == (hv))
 
 #endif /* USE_ITHREADS */
 
+#if { VERSION >= 5.6.0 }
+#ifndef caller_cx
+
+# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
+static I32
+DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock)
+{
+    I32 i;
+
+    for (i = startingblock; i >= 0; i--) {
+	register const PERL_CONTEXT * const cx = &cxstk[i];
+	switch (CxTYPE(cx)) {
+	default:
+	    continue;
+	case CXt_EVAL:
+	case CXt_SUB:
+	case CXt_FORMAT:
+	    return i;
+	}
+    }
+    return i;
+}
+# endif
+
+# if { NEED caller_cx }
+
+const PERL_CONTEXT *
+caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
+{
+    register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix);
+    register const PERL_CONTEXT *cx;
+    register const PERL_CONTEXT *ccstack = cxstack;
+    const PERL_SI *top_si = PL_curstackinfo;
+
+    for (;;) {
+	/* we may be in a higher stacklevel, so dig down deeper */
+	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
+	    top_si = top_si->si_prev;
+	    ccstack = top_si->si_cxstack;
+	    cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
+	}
+	if (cxix < 0)
+	    return NULL;
+	/* caller() should not report the automatic calls to &DB::sub */
+	if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
+		ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
+	    count++;
+	if (!count--)
+	    break;
+	cxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
+    }
+
+    cx = &ccstack[cxix];
+    if (dbcxp) *dbcxp = cx;
+
+    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+        const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
+	/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
+	   field below is defined for any cx. */
+	/* caller() should not report the automatic calls to &DB::sub */
+	if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
+	    cx = &ccstack[dbcxix];
+    }
+
+    return cx;
+}
+
+# endif
+#endif /* caller_cx */
+#endif /* 5.6.0 */
+
+=xsinit
+
+#define NEED_caller_cx
+
 =xsubs
 
 char *
@@ -62,7 +138,36 @@ CopFILE()
         OUTPUT:
                 RETVAL
 
-=tests plan => 2
+#if { VERSION >= 5.6.0 }
+
+void
+caller_cx(level)
+        I32 level
+    PREINIT:
+        const PERL_CONTEXT *cx, *dbcx;
+        const char *pv;
+        const GV *gv;
+    PPCODE:
+        cx = caller_cx(level, &dbcx);
+        if (!cx) XSRETURN_EMPTY;
+
+        EXTEND(SP, 4);
+
+        pv = CopSTASHPV(cx->blk_oldcop);
+        ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
+        gv = CvGV(cx->blk_sub.cv);
+        ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
+
+        pv = CopSTASHPV(dbcx->blk_oldcop);
+        ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
+        gv = CvGV(dbcx->blk_sub.cv);
+        ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
+
+        XSRETURN(4);
+
+#endif /* 5.6.0 */
+
+=tests plan => 28
 
 my $package;
 {
@@ -75,3 +180,52 @@ ok($package, "MyPackage");
 my $file = &Devel::PPPort::CopFILE();
 print "# $file\n";
 ok($file =~ /cop/i);
+
+BEGIN {
+  if ($] < 5.006000) {
+    # Skip
+    for (1..28) {
+      ok(1, 1);
+    }
+    exit;
+  }
+}
+
+BEGIN {
+    package DB;
+    no strict "refs";
+    local $^P = 1;
+    sub sub { &$DB::sub }
+}
+
+{ package One; sub one { Devel::PPPort::caller_cx($_[0]) } }
+{
+    package Two;
+    sub two { One::one(@_) }
+    sub dbtwo {
+        BEGIN { $^P = 1 }
+        One::one(@_);
+        BEGIN { $^P = 0 }
+    }
+}
+
+for (
+    # This is rather confusing. The package is the package the call is
+    # made *from*, the sub name is the sub the call is made *to*. When
+    # DB::sub is involved the first call is to DB::sub from the calling
+    # package, the second is to the real sub from package DB.
+    [\&One::one, 0, qw/main one main one/],
+    [\&One::one, 2, ],
+    [\&Two::two, 0, qw/Two one Two one/],
+    [\&Two::two, 1, qw/main two main two/],
+    [\&Two::dbtwo, 0, qw/Two sub DB one/],
+    [\&Two::dbtwo, 1, qw/main dbtwo main dbtwo/],
+) {
+    my ($sub, $arg, @want) = @$_;
+    my @got = $sub->($arg);
+    ok(@got, @want);
+    for (0..$#want) {
+        ok($got[$_], $want[$_]);
+    }
+}
+
diff --git a/cpan/Devel-PPPort/parts/inc/magic b/cpan/Devel-PPPort/parts/inc/magic
index 136758dd9e..de6f438d8f 100644
--- a/cpan/Devel-PPPort/parts/inc/magic
+++ b/cpan/Devel-PPPort/parts/inc/magic
@@ -343,7 +343,6 @@ new_with_other_mg(package, ...)
     HV *self;
     HV *stash;
     SV *self_ref;
-    int i = 0;
     const char *data = "hello\0";
     MAGIC *mg;
   CODE:
@@ -354,7 +353,10 @@ new_with_other_mg(package, ...)
 
     sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
     mg = mg_find((SV*)self, PERL_MAGIC_ext);
-    mg->mg_virtual = &other_mg_vtbl;
+    if (mg)
+      mg->mg_virtual = &other_mg_vtbl;
+    else
+      croak("No mg!");
 
     RETVAL = sv_bless(self_ref, stash);
   OUTPUT:
@@ -367,7 +369,6 @@ new_with_mg(package, ...)
     HV *self;
     HV *stash;
     SV *self_ref;
-    int i = 0;
     const char *data = "hello\0";
     MAGIC *mg;
   CODE:
@@ -378,7 +379,10 @@ new_with_mg(package, ...)
 
     sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
     mg = mg_find((SV*)self, PERL_MAGIC_ext);
-    mg->mg_virtual = &null_mg_vtbl;
+    if (mg)
+      mg->mg_virtual = &null_mg_vtbl;
+    else
+      croak("No mg!");
 
     RETVAL = sv_bless(self_ref, stash);
   OUTPUT:
@@ -521,6 +525,9 @@ sv_magic_portable(sv)
 #if { VERSION >= 5.004 }
                 sv_magic_portable(sv, 0, '~', foo, 0);
                 mg = mg_find(sv, '~');
+                if (!mg)
+                  croak("No mg!");
+
                 RETVAL = mg->mg_ptr == foo;
 #else
                 sv_magic(sv, 0, '~', (char *) foo, strlen(foo));
diff --git a/cpan/Devel-PPPort/parts/inc/variables b/cpan/Devel-PPPort/parts/inc/variables
index 0898ab5f6f..7ae6fabcd5 100644
--- a/cpan/Devel-PPPort/parts/inc/variables
+++ b/cpan/Devel-PPPort/parts/inc/variables
@@ -222,7 +222,7 @@ extern U32 get_PL_signals_3(void);
 int no_dummy_parser_vars(int);
 int dummy_parser_warning(void);
 
-#define ppp_TESTVAR(var)          STMT_START { mXPUSHi(&var != NULL); count++; } STMT_END
+#define ppp_TESTVAR(var)          STMT_START { mXPUSHi(&var); count++; } STMT_END
 
 #define ppp_PARSERVAR(type, var)  STMT_START {                   \
                                     type volatile my_ ## var;    \
diff --git a/cpan/Devel-PPPort/soak b/cpan/Devel-PPPort/soak
index 893212ba2f..2f13412763 100644
--- a/cpan/Devel-PPPort/soak
+++ b/cpan/Devel-PPPort/soak
@@ -27,7 +27,7 @@ use File::Find;
 use List::Util qw(max);
 use Config;
 
-my $VERSION = '3.24';
+my $VERSION = '3.25';
 
 $| = 1;
 my %OPT = (
diff --git a/cpan/Devel-PPPort/t/cop.t b/cpan/Devel-PPPort/t/cop.t
index 1162a5ed50..1677dee79a 100644
--- a/cpan/Devel-PPPort/t/cop.t
+++ b/cpan/Devel-PPPort/t/cop.t
@@ -30,9 +30,9 @@ BEGIN {
     require 'testutil.pl' if $@;
   }
 
-  if (2) {
+  if (28) {
     load();
-    plan(tests => 2);
+    plan(tests => 28);
   }
 }
 
@@ -60,3 +60,51 @@ my $file = &Devel::PPPort::CopFILE();
 print "# $file\n";
 ok($file =~ /cop/i);
 
+BEGIN {
+  if ($] < 5.006000) {
+    # Skip
+    for (1..28) {
+      ok(1, 1);
+    }
+    exit;
+  }
+}
+
+BEGIN {
+    package DB;
+    no strict "refs";
+    local $^P = 1;
+    sub sub { &$DB::sub }
+}
+
+{ package One; sub one { Devel::PPPort::caller_cx($_[0]) } }
+{
+    package Two;
+    sub two { One::one(@_) }
+    sub dbtwo {
+        BEGIN { $^P = 1 }
+        One::one(@_);
+        BEGIN { $^P = 0 }
+    }
+}
+
+for (
+    # This is rather confusing. The package is the package the call is
+    # made *from*, the sub name is the sub the call is made *to*. When
+    # DB::sub is involved the first call is to DB::sub from the calling
+    # package, the second is to the real sub from package DB.
+    [\&One::one, 0, qw/main one main one/],
+    [\&One::one, 2, ],
+    [\&Two::two, 0, qw/Two one Two one/],
+    [\&Two::two, 1, qw/main two main two/],
+    [\&Two::dbtwo, 0, qw/Two sub DB one/],
+    [\&Two::dbtwo, 1, qw/main dbtwo main dbtwo/],
+) {
+    my ($sub, $arg, @want) = @$_;
+    my @got = $sub->($arg);
+    ok(@got, @want);
+    for (0..$#want) {
+        ok($got[$_], $want[$_]);
+    }
+}
+