Upgrade Devel::PPPort from 3.21 to 3.22

  [DELTA]

    * Add support for the following API
        SvREFCNT_dec_NN
        mg_findext
        sv_unmagicext
    * Update META
        Move bug tracker to github
        Provide link to repository

11 files changed, 317 insertions, 12 deletions

diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 4b48564814..ce13163e6d 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -351,7 +351,7 @@ use File::Glob qw(:case);
     },
 
     'Devel::PPPort' => {
-        'DISTRIBUTION' => 'MHX/Devel-PPPort-3.21.tar.gz',
+        'DISTRIBUTION' => 'WOLFSAGE/Devel-PPPort-3.22.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/Makefile.PL b/cpan/Devel-PPPort/Makefile.PL
index 2353324b0d..25e352e641 100644
--- a/cpan/Devel-PPPort/Makefile.PL
+++ b/cpan/Devel-PPPort/Makefile.PL
@@ -34,6 +34,21 @@ WriteMakefile(
   OBJECT        => 'RealPPPort$(OBJ_EXT) $(O_FILES)',
   XSPROTOARG    => '-noprototypes',
   CONFIGURE     => \&configure,
+  META_MERGE    => {
+    'meta-spec' => {
+      version => 2,
+    },
+    resources => {
+      bugtracker => {
+        web => 'https://github.com/mhx/Devel-PPPort/issues/',
+      },
+      repository => {
+        type => 'git',
+        url  => 'git://github.com/mhx/Devel-PPPort.git',
+        web  => 'https://github.com/mhx/Devel-PPPort/',
+      },
+    },
+  },
 );
 
 sub configure
diff --git a/cpan/Devel-PPPort/PPPort_pm.PL b/cpan/Devel-PPPort/PPPort_pm.PL
index 23ffb6b149..4a302528d4 100644
--- a/cpan/Devel-PPPort/PPPort_pm.PL
+++ b/cpan/Devel-PPPort/PPPort_pm.PL
@@ -499,6 +499,10 @@ Version 2.x was ported to the Perl core by Paul Marquess.
 
 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
 
+=item * 
+
+Versions >= 3.22 are maintained with support from Matthew Horsfall (alh).
+
 =back
 
 =head1 COPYRIGHT
@@ -523,7 +527,7 @@ package Devel::PPPort;
 use strict;
 use vars qw($VERSION $data);
 
-$VERSION = '3.21';
+$VERSION = '3.22';
 
 sub _init_data
 {
diff --git a/cpan/Devel-PPPort/parts/apicheck.pl b/cpan/Devel-PPPort/parts/apicheck.pl
index e11187f14f..bea9bac503 100644
--- a/cpan/Devel-PPPort/parts/apicheck.pl
+++ b/cpan/Devel-PPPort/parts/apicheck.pl
@@ -146,6 +146,7 @@ print OUT <<HEAD;
 #define NEED_load_module
 #define NEED_my_snprintf
 #define NEED_my_sprintf
+#define NEED_mg_findext
 #define NEED_my_strlcat
 #define NEED_my_strlcpy
 #define NEED_newCONSTSUB
diff --git a/cpan/Devel-PPPort/parts/inc/SvREFCNT b/cpan/Devel-PPPort/parts/inc/SvREFCNT
index 422aa58ac8..3c113e8ae0 100644
--- a/cpan/Devel-PPPort/parts/inc/SvREFCNT
+++ b/cpan/Devel-PPPort/parts/inc/SvREFCNT
@@ -15,6 +15,7 @@ SvREFCNT_inc
 SvREFCNT_inc_simple
 SvREFCNT_inc_NN
 SvREFCNT_inc_void
+SvREFCNT_dec_NN
 __UNDEFINED__
 
 =implementation
@@ -76,6 +77,20 @@ __UNDEFINED__
 #  endif
 #endif
 
+#ifndef SvREFCNT_dec_NN
+#  ifdef PERL_USE_GCC_BRACE_GROUPS
+#    define SvREFCNT_dec_NN(sv)        \
+      ({                               \
+          SV * const _sv = (SV*)(sv);  \
+          SvREFCNT(_sv)--;             \
+          _sv;                         \
+      })
+#  else
+#    define SvREFCNT_dec_NN(sv) \
+          (PL_Sv=(SV*)(sv),--(SvREFCNT(PL_Sv)),PL_Sv)
+#  endif
+#endif
+
 __UNDEFINED__  SvREFCNT_inc_simple_void(sv)     STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
 __UNDEFINED__  SvREFCNT_inc_simple_NN(sv)       (++SvREFCNT(sv), (SV*)(sv))
 __UNDEFINED__  SvREFCNT_inc_void_NN(sv)         (void)(++SvREFCNT((SV*)(sv)))
@@ -110,13 +125,15 @@ SvREFCNT()
                 mXPUSHi(SvREFCNT(sv) == 8);
                 SvREFCNT_inc_simple_void_NN(sv);
                 mXPUSHi(SvREFCNT(sv) == 9);
+                SvREFCNT_dec_NN(sv);
+                mXPUSHi(SvREFCNT(sv) == 8);
                 while (SvREFCNT(sv) > 1)
                   SvREFCNT_dec(sv);
                 mXPUSHi(SvREFCNT(sv) == 1);
                 SvREFCNT_dec(sv);
-                XSRETURN(14);
+                XSRETURN(15);
 
-=tests plan => 14
+=tests plan => 15
 
 for (Devel::PPPort::SvREFCNT()) {
   ok(defined $_ and $_);
diff --git a/cpan/Devel-PPPort/parts/inc/call b/cpan/Devel-PPPort/parts/inc/call
index 6ccd9e7fc0..7d8e4d37e5 100644
--- a/cpan/Devel-PPPort/parts/inc/call
+++ b/cpan/Devel-PPPort/parts/inc/call
@@ -124,6 +124,9 @@ vload_module(U32 flags, SV *name, SV *ver, va_list *args)
 #if { VERSION >= 5.004 }
         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
                 veop, modname, imop);
+#elif { VERSION > 5.003 }
+        utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
+                veop, modname, imop);
 #else
         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
                 modname, imop);
diff --git a/cpan/Devel-PPPort/parts/inc/magic b/cpan/Devel-PPPort/parts/inc/magic
index 59cd40befe..6fe1ac8811 100644
--- a/cpan/Devel-PPPort/parts/inc/magic
+++ b/cpan/Devel-PPPort/parts/inc/magic
@@ -11,14 +11,34 @@
 
 =provides
 
+mg_findext
+sv_unmagicext
+
 __UNDEFINED__
 /sv_\w+_mg/
 sv_magic_portable
+MUTABLE_PTR
+MUTABLE_SV
 
 =implementation
 
 __UNDEFINED__  SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
 
+/* Some random bits for sv_unmagicext. These should probably be pulled in for
+   real and organized at some point */
+
+__UNDEFINED__  HEf_SVKEY   -2
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+#  define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
+#else
+#  define MUTABLE_PTR(p) ((void *) (p))
+#endif
+
+#define MUTABLE_SV(p)   ((SV *)MUTABLE_PTR(p))
+
+/* end of random bits */
+
 __UNDEFINED__  PERL_MAGIC_sv              '\0'
 __UNDEFINED__  PERL_MAGIC_overload        'A'
 __UNDEFINED__  PERL_MAGIC_overload_elem   'a'
@@ -200,8 +220,205 @@ __UNDEFINED__  SvVSTRING_mg(sv)  (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring
 
 #endif
 
+#if !defined(mg_findext)
+#if { NEED mg_findext }
+
+MAGIC *
+mg_findext(pTHX_ SV * sv, int type, const MGVTBL *vtbl) {
+    if (sv) {
+        MAGIC *mg;
+
+#ifdef AvPAD_NAMELIST
+	assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
+#endif
+
+        for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
+            if (mg->mg_type == type && mg->mg_virtual == vtbl)
+                return mg;
+        }
+    }
+
+    return NULL;
+}
+
+#endif
+#endif
+
+#if !defined(sv_unmagicext)
+#if { NEED sv_unmagicext }
+
+int
+sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+{
+    MAGIC* mg;
+    MAGIC** mgp;
+
+    if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
+	return 0;
+    mgp = &(SvMAGIC(sv));
+    for (mg = *mgp; mg; mg = *mgp) {
+	const MGVTBL* const virt = mg->mg_virtual;
+	if (mg->mg_type == type && virt == vtbl) {
+	    *mgp = mg->mg_moremagic;
+	    if (virt && virt->svt_free)
+		virt->svt_free(aTHX_ sv, mg);
+	    if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
+		if (mg->mg_len > 0)
+		    Safefree(mg->mg_ptr);
+		else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */
+		    SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
+		else if (mg->mg_type == PERL_MAGIC_utf8)
+		    Safefree(mg->mg_ptr);
+            }
+	    if (mg->mg_flags & MGf_REFCOUNTED)
+		SvREFCNT_dec(mg->mg_obj);
+	    Safefree(mg);
+	}
+	else
+	    mgp = &mg->mg_moremagic;
+    }
+    if (SvMAGIC(sv)) {
+	if (SvMAGICAL(sv))	/* if we're under save_magic, wait for restore_magic; */
+	    mg_magical(sv);	/*    else fix the flags now */
+    }
+    else {
+	SvMAGICAL_off(sv);
+	SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+    }
+    return 0;
+}
+
+#endif
+#endif
+
+=xsinit
+
+#define NEED_mg_findext
+#define NEED_sv_unmagicext
+
+#ifndef STATIC
+#define STATIC static
+#endif
+
+STATIC MGVTBL null_mg_vtbl = {
+    NULL, /* get */
+    NULL, /* set */
+    NULL, /* len */
+    NULL, /* clear */
+    NULL, /* free */
+#if MGf_COPY
+    NULL, /* copy */
+#endif /* MGf_COPY */
+#if MGf_DUP
+    NULL, /* dup */
+#endif /* MGf_DUP */
+#if MGf_LOCAL
+    NULL, /* local */
+#endif /* MGf_LOCAL */
+};
+
+STATIC MGVTBL other_mg_vtbl = {
+    NULL, /* get */
+    NULL, /* set */
+    NULL, /* len */
+    NULL, /* clear */
+    NULL, /* free */
+#if MGf_COPY
+    NULL, /* copy */
+#endif /* MGf_COPY */
+#if MGf_DUP
+    NULL, /* dup */
+#endif /* MGf_DUP */
+#if MGf_LOCAL
+    NULL, /* local */
+#endif /* MGf_LOCAL */
+};
+
 =xsubs
 
+SV *
+new_with_other_mg(package, ...)
+    SV *package
+  PREINIT:
+    HV *self;
+    HV *stash;
+    SV *self_ref;
+    int i = 0;
+    const char *data = "hello\0";
+    MAGIC *mg;
+  CODE:
+    self = newHV();
+    stash = gv_stashpv(SvPV_nolen(package), 0);
+
+    self_ref = newRV_noinc((SV*)self);
+
+    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;
+
+    RETVAL = sv_bless(self_ref, stash);
+  OUTPUT:
+    RETVAL
+
+SV *
+new_with_mg(package, ...)
+    SV *package
+  PREINIT:
+    HV *self;
+    HV *stash;
+    SV *self_ref;
+    int i = 0;
+    const char *data = "hello\0";
+    MAGIC *mg;
+  CODE:
+    self = newHV();
+    stash = gv_stashpv(SvPV_nolen(package), 0);
+
+    self_ref = newRV_noinc((SV*)self);
+
+    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;
+
+    RETVAL = sv_bless(self_ref, stash);
+  OUTPUT:
+    RETVAL
+
+void
+remove_null_magic(self)
+    SV *self
+  PREINIT:
+    HV *obj;
+  PPCODE:
+    obj = (HV*) SvRV(self);
+
+    sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl);
+
+void
+remove_other_magic(self)
+    SV *self
+  PREINIT:
+    HV *obj;
+  PPCODE:
+    obj = (HV*) SvRV(self);
+
+    sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &other_mg_vtbl);
+
+void
+as_string(self)
+    SV *self
+  PREINIT:
+    HV *obj;
+    MAGIC *mg;
+  PPCODE:
+    obj = (HV*) SvRV(self);
+
+    if (mg = mg_findext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl)) {
+        XPUSHs(sv_2mortal(newSVpv(mg->mg_ptr, strlen(mg->mg_ptr))));
+    } else {
+	XPUSHs(sv_2mortal(newSVpvs("Sorry, your princess is in another castle.")));
+    }
+
 void
 sv_catpv_mg(sv, string)
         SV *sv;
@@ -314,7 +531,31 @@ sv_magic_portable(sv)
         OUTPUT:
                 RETVAL
 
-=tests plan => 15
+=tests plan => 23
+
+# Find proper magic
+ok(my $obj1 = Devel::PPPort->new_with_mg());
+ok(Devel::PPPort::as_string($obj1), 'hello');
+
+# Find with no magic
+my $obj = bless {}, 'Fake::Class';
+ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
+
+# Find with other magic (not the magic we are looking for)
+ok($obj = Devel::PPPort->new_with_other_mg());
+ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
+
+# Okay, attempt to remove magic that isn't there
+Devel::PPPort::remove_other_magic($obj1);
+ok(Devel::PPPort::as_string($obj1), 'hello');
+
+# Remove magic that IS there
+Devel::PPPort::remove_null_magic($obj1);
+ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
+
+# Removing when no magic present
+Devel::PPPort::remove_null_magic($obj1);
+ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
 
 use Tie::Hash;
 my %h;
diff --git a/cpan/Devel-PPPort/parts/inc/pv_tools b/cpan/Devel-PPPort/parts/inc/pv_tools
index a8a477fa17..41a4907c6b 100644
--- a/cpan/Devel-PPPort/parts/inc/pv_tools
+++ b/cpan/Devel-PPPort/parts/inc/pv_tools
@@ -80,10 +80,10 @@ pv_escape(pTHX_ SV *dsv, char const * const str,
         if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
                 chsize = my_snprintf(octbuf, sizeof octbuf,
-                                      "%"UVxf, u);
+                                      "%" UVxf, u);
             else
                 chsize = my_snprintf(octbuf, sizeof octbuf,
-                                      "%cx{%"UVxf"}", esc, u);
+                                      "%cx{%" UVxf "}", esc, u);
         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
             chsize = 1;
         } else {
diff --git a/cpan/Devel-PPPort/soak b/cpan/Devel-PPPort/soak
index da0dfae557..522d6ea5f6 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.21';
+my $VERSION = '3.22';
 
 $| = 1;
 my %OPT = (
diff --git a/cpan/Devel-PPPort/t/SvREFCNT.t b/cpan/Devel-PPPort/t/SvREFCNT.t
index 0b46a51793..7f228b0ff3 100644
--- a/cpan/Devel-PPPort/t/SvREFCNT.t
+++ b/cpan/Devel-PPPort/t/SvREFCNT.t
@@ -30,9 +30,9 @@ BEGIN {
     require 'testutil.pl' if $@;
   }
 
-  if (14) {
+  if (15) {
     load();
-    plan(tests => 14);
+    plan(tests => 15);
   }
 }
 
diff --git a/cpan/Devel-PPPort/t/magic.t b/cpan/Devel-PPPort/t/magic.t
index 0bfe0535f2..f467613f27 100644
--- a/cpan/Devel-PPPort/t/magic.t
+++ b/cpan/Devel-PPPort/t/magic.t
@@ -30,9 +30,9 @@ BEGIN {
     require 'testutil.pl' if $@;
   }
 
-  if (15) {
+  if (23) {
     load();
-    plan(tests => 15);
+    plan(tests => 23);
   }
 }
 
@@ -48,6 +48,30 @@ bootstrap Devel::PPPort;
 
 package main;
 
+# Find proper magic
+ok(my $obj1 = Devel::PPPort->new_with_mg());
+ok(Devel::PPPort::as_string($obj1), 'hello');
+
+# Find with no magic
+my $obj = bless {}, 'Fake::Class';
+ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
+
+# Find with other magic (not the magic we are looking for)
+ok($obj = Devel::PPPort->new_with_other_mg());
+ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
+
+# Okay, attempt to remove magic that isn't there
+Devel::PPPort::remove_other_magic($obj1);
+ok(Devel::PPPort::as_string($obj1), 'hello');
+
+# Remove magic that IS there
+Devel::PPPort::remove_null_magic($obj1);
+ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
+
+# Removing when no magic present
+Devel::PPPort::remove_null_magic($obj1);
+ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
+
 use Tie::Hash;
 my %h;
 tie %h, 'Tie::StdHash';