From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 24 Nov 2007 20:15:51 +0000 (+0000)
Subject: Create a branch for code changes to XS code that 5.8.x needs, which
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=407b1e18e8abd1cc85bd65f037956774b86f3f1f;p=p5sagit%2Fp5-mst-13.2.git

Create a branch for code changes to XS code that 5.8.x needs, which
can't yet be merged to blead beacuse of the code freeze for 5.10.
For now, XS::APItest

p4raw-id: //depot/perl@32480
---

diff --git a/blead-maint-fixup/ext/XS/APItest/APItest.pm b/blead-maint-fixup/ext/XS/APItest/APItest.pm
new file mode 100644
index 0000000..17e6abb
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/APItest.pm
@@ -0,0 +1,229 @@
+package XS::APItest;
+
+use 5.008;
+use strict;
+use warnings;
+use Carp;
+
+use base qw/ DynaLoader Exporter /;
+
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# Export everything since these functions are only used by a test script
+our @EXPORT = qw( print_double print_int print_long
+		  print_float print_long_double have_long_double print_flush
+		  mpushp mpushn mpushi mpushu
+		  mxpushp mxpushn mxpushi mxpushu
+		  call_sv call_pv call_method eval_sv eval_pv require_pv
+		  G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS
+		  G_KEEPERR G_NODEBUG G_METHOD
+		  apitest_exception mycroak strtab
+		  my_cxt_getint my_cxt_getsv my_cxt_setint my_cxt_setsv
+		  sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore
+);
+
+# from cop.h 
+sub G_SCALAR()	{   0 }
+sub G_ARRAY()	{   1 }
+sub G_VOID()	{ 128 }
+sub G_DISCARD()	{   2 }
+sub G_EVAL()	{   4 }
+sub G_NOARGS()	{   8 }
+sub G_KEEPERR()	{  16 }
+sub G_NODEBUG()	{  32 }
+sub G_METHOD()	{  64 }
+
+our $VERSION = '0.12';
+
+use vars '$WARNINGS_ON_BOOTSTRAP';
+use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
+
+# Do these here to verify that XS code and Perl code get called at the same
+# times
+BEGIN {
+    $BEGIN_called_PP++;
+}
+UNITCHECK {
+    $UNITCHECK_called_PP++;
+}
+{
+    # Need $W false by default, as some tests run under -w, and under -w we
+    # can get warnings about "Too late to run CHECK" block (and INIT block)
+    no warnings 'void';
+    CHECK {
+	$CHECK_called_PP++;
+    }
+    INIT {
+	$INIT_called_PP++;
+    }
+}
+END {
+    $END_called_PP++;
+}
+
+if ($WARNINGS_ON_BOOTSTRAP) {
+    bootstrap XS::APItest $VERSION;
+} else {
+    # More CHECK and INIT blocks that could warn:
+    local $^W;
+    bootstrap XS::APItest $VERSION;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+XS::APItest - Test the perl C API
+
+=head1 SYNOPSIS
+
+  use XS::APItest;
+  print_double(4);
+
+=head1 ABSTRACT
+
+This module tests the perl C API. Currently tests that C<printf>
+works correctly.
+
+=head1 DESCRIPTION
+
+This module can be used to check that the perl C API is behaving
+correctly. This module provides test functions and an associated
+test script that verifies the output.
+
+This module is not meant to be installed.
+
+=head2 EXPORT
+
+Exports all the test functions:
+
+=over 4
+
+=item B<print_double>
+
+Test that a double-precision floating point number is formatted
+correctly by C<printf>.
+
+  print_double( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_long_double>
+
+Test that a C<long double> is formatted correctly by
+C<printf>. Takes no arguments - the test value is hard-wired
+into the function (as "7").
+
+  print_long_double();
+
+Output is sent to STDOUT.
+
+=item B<have_long_double>
+
+Determine whether a C<long double> is supported by Perl.  This should
+be used to determine whether to test C<print_long_double>.
+
+  print_long_double() if have_long_double;
+
+=item B<print_nv>
+
+Test that an C<NV> is formatted correctly by
+C<printf>.
+
+  print_nv( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_iv>
+
+Test that an C<IV> is formatted correctly by
+C<printf>.
+
+  print_iv( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_uv>
+
+Test that an C<UV> is formatted correctly by
+C<printf>.
+
+  print_uv( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_int>
+
+Test that an C<int> is formatted correctly by
+C<printf>.
+
+  print_int( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_long>
+
+Test that an C<long> is formatted correctly by
+C<printf>.
+
+  print_long( $val );
+
+Output is sent to STDOUT.
+
+=item B<print_float>
+
+Test that a single-precision floating point number is formatted
+correctly by C<printf>.
+
+  print_float( $val );
+
+Output is sent to STDOUT.
+
+=item B<call_sv>, B<call_pv>, B<call_method>
+
+These exercise the C calls of the same names. Everything after the flags
+arg is passed as the the args to the called function. They return whatever
+the C function itself pushed onto the stack, plus the return value from
+the function; for example
+
+    call_sv( sub { @_, 'c' }, G_ARRAY,  'a', 'b'); # returns 'a', 'b', 'c', 3
+    call_sv( sub { @_ },      G_SCALAR, 'a', 'b'); # returns 'b', 1
+
+=item B<eval_sv>
+
+Evaluates the passed SV. Result handling is done the same as for
+C<call_sv()> etc.
+
+=item B<eval_pv>
+
+Exercises the C function of the same name in scalar context. Returns the
+same SV that the C function returns.
+
+=item B<require_pv>
+
+Exercises the C function of the same name. Returns nothing.
+
+=back
+
+=head1 SEE ALSO
+
+L<XS::Typemap>, L<perlapi>.
+
+=head1 AUTHORS
+
+Tim Jenness, E<lt>t.jenness@jach.hawaii.eduE<gt>,
+Christian Soeller, E<lt>csoelle@mph.auckland.ac.nzE<gt>,
+Hugo van der Sanden E<lt>hv@crypt.compulink.co.ukE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002,2004 Tim Jenness, Christian Soeller, Hugo van der Sanden.
+All Rights Reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. 
+
+=cut
diff --git a/blead-maint-fixup/ext/XS/APItest/APItest.xs b/blead-maint-fixup/ext/XS/APItest/APItest.xs
new file mode 100644
index 0000000..5ea6f4f
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/APItest.xs
@@ -0,0 +1,828 @@
+#define PERL_IN_XS_APITEST
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+
+/* for my_cxt tests */
+
+#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
+
+typedef struct {
+    int i;
+    SV *sv;
+} my_cxt_t;
+
+START_MY_CXT
+
+/* indirect functions to test the [pa]MY_CXT macros */
+
+int
+my_cxt_getint_p(pMY_CXT)
+{
+    return MY_CXT.i;
+}
+
+void
+my_cxt_setint_p(pMY_CXT_ int i)
+{
+    MY_CXT.i = i;
+}
+
+SV*
+my_cxt_getsv_interp(void)
+{
+#ifdef PERL_IMPLICIT_CONTEXT
+    dTHX;
+    dMY_CXT_INTERP(my_perl);
+#else
+    dMY_CXT;
+#endif
+    return MY_CXT.sv;
+}
+
+void
+my_cxt_setsv_p(SV* sv _pMY_CXT)
+{
+    MY_CXT.sv = sv;
+}
+
+
+/* from exception.c */
+int apitest_exception(int);
+
+/* from core_or_not.inc */
+bool sv_setsv_cow_hashkey_core(void);
+bool sv_setsv_cow_hashkey_notcore(void);
+
+/* A routine to test hv_delayfree_ent
+   (which itself is tested by testing on hv_free_ent  */
+
+typedef void (freeent_function)(pTHX_ HV *, register HE *);
+
+void
+test_freeent(freeent_function *f) {
+    dTHX;
+    dSP;
+    HV *test_hash = newHV();
+    HE *victim;
+    SV *test_scalar;
+    U32 results[4];
+    int i;
+
+#ifdef PURIFY
+    victim = (HE*)safemalloc(sizeof(HE));
+#else
+    /* Storing then deleting something should ensure that a hash entry is
+       available.  */
+    hv_store(test_hash, "", 0, &PL_sv_yes, 0);
+    hv_delete(test_hash, "", 0, 0);
+
+    /* We need to "inline" new_he here as it's static, and the functions we
+       test expect to be able to call del_HE on the HE  */
+    if (!PL_body_roots[HE_SVSLOT])
+	croak("PL_he_root is 0");
+    victim = (HE*) PL_body_roots[HE_SVSLOT];
+    PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
+#endif
+
+    victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
+
+    test_scalar = newSV(0);
+    SvREFCNT_inc(test_scalar);
+    HeVAL(victim) = test_scalar;
+
+    /* Need this little game else we free the temps on the return stack.  */
+    results[0] = SvREFCNT(test_scalar);
+    SAVETMPS;
+    results[1] = SvREFCNT(test_scalar);
+    f(aTHX_ test_hash, victim);
+    results[2] = SvREFCNT(test_scalar);
+    FREETMPS;
+    results[3] = SvREFCNT(test_scalar);
+
+    i = 0;
+    do {
+	mPUSHu(results[i]);
+    } while (++i < sizeof(results)/sizeof(results[0]));
+
+    /* Goodbye to our extra reference.  */
+    SvREFCNT_dec(test_scalar);
+}
+
+
+static I32
+bitflip_key(pTHX_ IV action, SV *field) {
+    MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
+    SV *keysv;
+    if (mg && (keysv = mg->mg_obj)) {
+	STRLEN len;
+	const char *p = SvPV(keysv, len);
+
+	if (len) {
+	    SV *newkey = newSV(len);
+	    char *new_p = SvPVX(newkey);
+
+	    if (SvUTF8(keysv)) {
+		const char *const end = p + len;
+		while (p < end) {
+		    STRLEN len;
+		    UV chr = utf8_to_uvuni((U8 *)p, &len);
+		    new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
+		    p += len;
+		}
+		SvUTF8_on(newkey);
+	    } else {
+		while (len--)
+		    *new_p++ = *p++ ^ 32;
+	    }
+	    *new_p = '\0';
+	    SvCUR_set(newkey, SvCUR(keysv));
+	    SvPOK_on(newkey);
+
+	    mg->mg_obj = newkey;
+	}
+    }
+    return 0;
+}
+
+static I32
+rot13_key(pTHX_ IV action, SV *field) {
+    MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
+    SV *keysv;
+    if (mg && (keysv = mg->mg_obj)) {
+	STRLEN len;
+	const char *p = SvPV(keysv, len);
+
+	if (len) {
+	    SV *newkey = newSV(len);
+	    char *new_p = SvPVX(newkey);
+
+	    /* There's a deliberate fencepost error here to loop len + 1 times
+	       to copy the trailing \0  */
+	    do {
+		char new_c = *p++;
+		/* Try doing this cleanly and clearly in EBCDIC another way: */
+		switch (new_c) {
+		case 'A': new_c = 'N'; break;
+		case 'B': new_c = 'O'; break;
+		case 'C': new_c = 'P'; break;
+		case 'D': new_c = 'Q'; break;
+		case 'E': new_c = 'R'; break;
+		case 'F': new_c = 'S'; break;
+		case 'G': new_c = 'T'; break;
+		case 'H': new_c = 'U'; break;
+		case 'I': new_c = 'V'; break;
+		case 'J': new_c = 'W'; break;
+		case 'K': new_c = 'X'; break;
+		case 'L': new_c = 'Y'; break;
+		case 'M': new_c = 'Z'; break;
+		case 'N': new_c = 'A'; break;
+		case 'O': new_c = 'B'; break;
+		case 'P': new_c = 'C'; break;
+		case 'Q': new_c = 'D'; break;
+		case 'R': new_c = 'E'; break;
+		case 'S': new_c = 'F'; break;
+		case 'T': new_c = 'G'; break;
+		case 'U': new_c = 'H'; break;
+		case 'V': new_c = 'I'; break;
+		case 'W': new_c = 'J'; break;
+		case 'X': new_c = 'K'; break;
+		case 'Y': new_c = 'L'; break;
+		case 'Z': new_c = 'M'; break;
+		case 'a': new_c = 'n'; break;
+		case 'b': new_c = 'o'; break;
+		case 'c': new_c = 'p'; break;
+		case 'd': new_c = 'q'; break;
+		case 'e': new_c = 'r'; break;
+		case 'f': new_c = 's'; break;
+		case 'g': new_c = 't'; break;
+		case 'h': new_c = 'u'; break;
+		case 'i': new_c = 'v'; break;
+		case 'j': new_c = 'w'; break;
+		case 'k': new_c = 'x'; break;
+		case 'l': new_c = 'y'; break;
+		case 'm': new_c = 'z'; break;
+		case 'n': new_c = 'a'; break;
+		case 'o': new_c = 'b'; break;
+		case 'p': new_c = 'c'; break;
+		case 'q': new_c = 'd'; break;
+		case 'r': new_c = 'e'; break;
+		case 's': new_c = 'f'; break;
+		case 't': new_c = 'g'; break;
+		case 'u': new_c = 'h'; break;
+		case 'v': new_c = 'i'; break;
+		case 'w': new_c = 'j'; break;
+		case 'x': new_c = 'k'; break;
+		case 'y': new_c = 'l'; break;
+		case 'z': new_c = 'm'; break;
+		}
+		*new_p++ = new_c;
+	    } while (len--);
+	    SvCUR_set(newkey, SvCUR(keysv));
+	    SvPOK_on(newkey);
+	    if (SvUTF8(keysv))
+		SvUTF8_on(newkey);
+
+	    mg->mg_obj = newkey;
+	}
+    }
+    return 0;
+}
+
+#include "const-c.inc"
+
+MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash
+
+INCLUDE: const-xs.inc
+
+void
+rot13_hash(hash)
+	HV *hash
+	CODE:
+	{
+	    struct ufuncs uf;
+	    uf.uf_val = rot13_key;
+	    uf.uf_set = 0;
+	    uf.uf_index = 0;
+
+	    sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
+	}
+
+void
+bitflip_hash(hash)
+	HV *hash
+	CODE:
+	{
+	    struct ufuncs uf;
+	    uf.uf_val = bitflip_key;
+	    uf.uf_set = 0;
+	    uf.uf_index = 0;
+
+	    sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
+	}
+
+#define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
+
+bool
+exists(hash, key_sv)
+	PREINIT:
+	STRLEN len;
+	const char *key;
+	INPUT:
+	HV *hash
+	SV *key_sv
+	CODE:
+	key = SvPV(key_sv, len);
+	RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
+        OUTPUT:
+        RETVAL
+
+bool
+exists_ent(hash, key_sv)
+	PREINIT:
+	INPUT:
+	HV *hash
+	SV *key_sv
+	CODE:
+	RETVAL = hv_exists_ent(hash, key_sv, 0);
+        OUTPUT:
+        RETVAL
+
+SV *
+delete(hash, key_sv, flags = 0)
+	PREINIT:
+	STRLEN len;
+	const char *key;
+	INPUT:
+	HV *hash
+	SV *key_sv
+	I32 flags;
+	CODE:
+	key = SvPV(key_sv, len);
+	/* It's already mortal, so need to increase reference count.  */
+	RETVAL
+	    = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
+        OUTPUT:
+        RETVAL
+
+SV *
+delete_ent(hash, key_sv, flags = 0)
+	INPUT:
+	HV *hash
+	SV *key_sv
+	I32 flags;
+	CODE:
+	/* It's already mortal, so need to increase reference count.  */
+	RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
+        OUTPUT:
+        RETVAL
+
+SV *
+store_ent(hash, key, value)
+	PREINIT:
+	SV *copy;
+	HE *result;
+	INPUT:
+	HV *hash
+	SV *key
+	SV *value
+	CODE:
+	copy = newSV(0);
+	result = hv_store_ent(hash, key, copy, 0);
+	SvSetMagicSV(copy, value);
+	if (!result) {
+	    SvREFCNT_dec(copy);
+	    XSRETURN_EMPTY;
+	}
+	/* It's about to become mortal, so need to increase reference count.
+	 */
+	RETVAL = SvREFCNT_inc(HeVAL(result));
+        OUTPUT:
+        RETVAL
+
+SV *
+store(hash, key_sv, value)
+	PREINIT:
+	STRLEN len;
+	const char *key;
+	SV *copy;
+	SV **result;
+	INPUT:
+	HV *hash
+	SV *key_sv
+	SV *value
+	CODE:
+	key = SvPV(key_sv, len);
+	copy = newSV(0);
+	result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
+	SvSetMagicSV(copy, value);
+	if (!result) {
+	    SvREFCNT_dec(copy);
+	    XSRETURN_EMPTY;
+	}
+	/* It's about to become mortal, so need to increase reference count.
+	 */
+	RETVAL = SvREFCNT_inc(*result);
+        OUTPUT:
+        RETVAL
+
+SV *
+fetch_ent(hash, key_sv)
+	PREINIT:
+	HE *result;
+	INPUT:
+	HV *hash
+	SV *key_sv
+	CODE:
+	result = hv_fetch_ent(hash, key_sv, 0, 0);
+	if (!result) {
+	    XSRETURN_EMPTY;
+	}
+	/* Force mg_get  */
+	RETVAL = newSVsv(HeVAL(result));
+        OUTPUT:
+        RETVAL
+
+SV *
+fetch(hash, key_sv)
+	PREINIT:
+	STRLEN len;
+	const char *key;
+	SV **result;
+	INPUT:
+	HV *hash
+	SV *key_sv
+	CODE:
+	key = SvPV(key_sv, len);
+	result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
+	if (!result) {
+	    XSRETURN_EMPTY;
+	}
+	/* Force mg_get  */
+	RETVAL = newSVsv(*result);
+        OUTPUT:
+        RETVAL
+
+SV *
+common(params)
+	INPUT:
+	HV *params
+	PREINIT:
+	HE *result;
+	HV *hv = NULL;
+	SV *keysv = NULL;
+	const char *key = NULL;
+	STRLEN klen = 0;
+	int flags = 0;
+	int action = 0;
+	SV *val = NULL;
+	U32 hash = 0;
+	SV **svp;
+	CODE:
+	if ((svp = hv_fetchs(params, "hv", 0))) {
+	    SV *const rv = *svp;
+	    if (!SvROK(rv))
+		croak("common passed a non-reference for parameter hv");
+	    hv = (HV *)SvRV(rv);
+	}
+	if ((svp = hv_fetchs(params, "keysv", 0)))
+	    keysv = *svp;
+	if ((svp = hv_fetchs(params, "keypv", 0))) {
+	    key = SvPV_const(*svp, klen);
+	    if (SvUTF8(*svp))
+		flags = HVhek_UTF8;
+	}
+	if ((svp = hv_fetchs(params, "action", 0)))
+	    action = SvIV(*svp);
+	if ((svp = hv_fetchs(params, "val", 0)))
+	    val = *svp;
+	if ((svp = hv_fetchs(params, "hash", 0)))
+	    action = SvUV(*svp);
+
+	result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
+	if (!result) {
+	    XSRETURN_EMPTY;
+	}
+	/* Force mg_get  */
+	RETVAL = newSVsv(HeVAL(result));
+        OUTPUT:
+        RETVAL
+
+void
+test_hv_free_ent()
+	PPCODE:
+	test_freeent(&Perl_hv_free_ent);
+	XSRETURN(4);
+
+void
+test_hv_delayfree_ent()
+	PPCODE:
+	test_freeent(&Perl_hv_delayfree_ent);
+	XSRETURN(4);
+
+SV *
+test_share_unshare_pvn(input)
+	PREINIT:
+	STRLEN len;
+	U32 hash;
+	char *pvx;
+	char *p;
+	INPUT:
+	SV *input
+	CODE:
+	pvx = SvPV(input, len);
+	PERL_HASH(hash, pvx, len);
+	p = sharepvn(pvx, len, hash);
+	RETVAL = newSVpvn(p, len);
+	unsharepvn(p, len, hash);
+	OUTPUT:
+	RETVAL
+
+bool
+refcounted_he_exists(key, level=0)
+	SV *key
+	IV level
+	CODE:
+	if (level) {
+	    croak("level must be zero, not %"IVdf, level);
+	}
+	RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+					   key, NULL, 0, 0, 0)
+		  != &PL_sv_placeholder);
+	OUTPUT:
+	RETVAL
+
+
+SV *
+refcounted_he_fetch(key, level=0)
+	SV *key
+	IV level
+	CODE:
+	if (level) {
+	    croak("level must be zero, not %"IVdf, level);
+	}
+	RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
+					  NULL, 0, 0, 0);
+	SvREFCNT_inc(RETVAL);
+	OUTPUT:
+	RETVAL
+	
+	
+=pod
+
+sub TIEHASH  { bless {}, $_[0] }
+sub STORE    { $_[0]->{$_[1]} = $_[2] }
+sub FETCH    { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY  { each %{$_[0]} }
+sub EXISTS   { exists $_[0]->{$_[1]} }
+sub DELETE   { delete $_[0]->{$_[1]} }
+sub CLEAR    { %{$_[0]} = () }
+
+=cut
+
+MODULE = XS::APItest		PACKAGE = XS::APItest
+
+PROTOTYPES: DISABLE
+
+BOOT:
+{
+    MY_CXT_INIT;
+    MY_CXT.i  = 99;
+    MY_CXT.sv = newSVpv("initial",0);
+}                              
+
+void
+CLONE(...)
+    CODE:
+    MY_CXT_CLONE;
+    MY_CXT.sv = newSVpv("initial_clone",0);
+
+void
+print_double(val)
+        double val
+        CODE:
+        printf("%5.3f\n",val);
+
+int
+have_long_double()
+        CODE:
+#ifdef HAS_LONG_DOUBLE
+        RETVAL = 1;
+#else
+        RETVAL = 0;
+#endif
+        OUTPUT:
+        RETVAL
+
+void
+print_long_double()
+        CODE:
+#ifdef HAS_LONG_DOUBLE
+#   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
+        long double val = 7.0;
+        printf("%5.3" PERL_PRIfldbl "\n",val);
+#   else
+        double val = 7.0;
+        printf("%5.3f\n",val);
+#   endif
+#endif
+
+void
+print_int(val)
+        int val
+        CODE:
+        printf("%d\n",val);
+
+void
+print_long(val)
+        long val
+        CODE:
+        printf("%ld\n",val);
+
+void
+print_float(val)
+        float val
+        CODE:
+        printf("%5.3f\n",val);
+	
+void
+print_flush()
+    	CODE:
+	fflush(stdout);
+
+void
+mpushp()
+	PPCODE:
+	EXTEND(SP, 3);
+	mPUSHp("one", 3);
+	mPUSHp("two", 3);
+	mPUSHp("three", 5);
+	XSRETURN(3);
+
+void
+mpushn()
+	PPCODE:
+	EXTEND(SP, 3);
+	mPUSHn(0.5);
+	mPUSHn(-0.25);
+	mPUSHn(0.125);
+	XSRETURN(3);
+
+void
+mpushi()
+	PPCODE:
+	EXTEND(SP, 3);
+	mPUSHi(-1);
+	mPUSHi(2);
+	mPUSHi(-3);
+	XSRETURN(3);
+
+void
+mpushu()
+	PPCODE:
+	EXTEND(SP, 3);
+	mPUSHu(1);
+	mPUSHu(2);
+	mPUSHu(3);
+	XSRETURN(3);
+
+void
+mxpushp()
+	PPCODE:
+	mXPUSHp("one", 3);
+	mXPUSHp("two", 3);
+	mXPUSHp("three", 5);
+	XSRETURN(3);
+
+void
+mxpushn()
+	PPCODE:
+	mXPUSHn(0.5);
+	mXPUSHn(-0.25);
+	mXPUSHn(0.125);
+	XSRETURN(3);
+
+void
+mxpushi()
+	PPCODE:
+	mXPUSHi(-1);
+	mXPUSHi(2);
+	mXPUSHi(-3);
+	XSRETURN(3);
+
+void
+mxpushu()
+	PPCODE:
+	mXPUSHu(1);
+	mXPUSHu(2);
+	mXPUSHu(3);
+	XSRETURN(3);
+
+
+void
+call_sv(sv, flags, ...)
+    SV* sv
+    I32 flags
+    PREINIT:
+	I32 i;
+    PPCODE:
+	for (i=0; i<items-2; i++)
+	    ST(i) = ST(i+2); /* pop first two args */
+	PUSHMARK(SP);
+	SP += items - 2;
+	PUTBACK;
+	i = call_sv(sv, flags);
+	SPAGAIN;
+	EXTEND(SP, 1);
+	PUSHs(sv_2mortal(newSViv(i)));
+
+void
+call_pv(subname, flags, ...)
+    char* subname
+    I32 flags
+    PREINIT:
+	I32 i;
+    PPCODE:
+	for (i=0; i<items-2; i++)
+	    ST(i) = ST(i+2); /* pop first two args */
+	PUSHMARK(SP);
+	SP += items - 2;
+	PUTBACK;
+	i = call_pv(subname, flags);
+	SPAGAIN;
+	EXTEND(SP, 1);
+	PUSHs(sv_2mortal(newSViv(i)));
+
+void
+call_method(methname, flags, ...)
+    char* methname
+    I32 flags
+    PREINIT:
+	I32 i;
+    PPCODE:
+	for (i=0; i<items-2; i++)
+	    ST(i) = ST(i+2); /* pop first two args */
+	PUSHMARK(SP);
+	SP += items - 2;
+	PUTBACK;
+	i = call_method(methname, flags);
+	SPAGAIN;
+	EXTEND(SP, 1);
+	PUSHs(sv_2mortal(newSViv(i)));
+
+void
+eval_sv(sv, flags)
+    SV* sv
+    I32 flags
+    PREINIT:
+    	I32 i;
+    PPCODE:
+	PUTBACK;
+	i = eval_sv(sv, flags);
+	SPAGAIN;
+	EXTEND(SP, 1);
+	PUSHs(sv_2mortal(newSViv(i)));
+
+void
+eval_pv(p, croak_on_error)
+    const char* p
+    I32 croak_on_error
+    PPCODE:
+	PUTBACK;
+	EXTEND(SP, 1);
+	PUSHs(eval_pv(p, croak_on_error));
+
+void
+require_pv(pv)
+    const char* pv
+    PPCODE:
+	PUTBACK;
+	require_pv(pv);
+
+int
+apitest_exception(throw_e)
+    int throw_e
+    OUTPUT:
+        RETVAL
+
+void
+mycroak(sv)
+    SV* sv
+    CODE:
+    if (SvOK(sv)) {
+        Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
+    }
+    else {
+	Perl_croak(aTHX_ NULL);
+    }
+
+SV*
+strtab()
+   CODE:
+   RETVAL = newRV_inc((SV*)PL_strtab);
+   OUTPUT:
+   RETVAL
+
+int
+my_cxt_getint()
+    CODE:
+	dMY_CXT;
+	RETVAL = my_cxt_getint_p(aMY_CXT);
+    OUTPUT:
+        RETVAL
+
+void
+my_cxt_setint(i)
+    int i;
+    CODE:
+	dMY_CXT;
+	my_cxt_setint_p(aMY_CXT_ i);
+
+void
+my_cxt_getsv()
+    PPCODE:
+	EXTEND(SP, 1);
+	ST(0) = my_cxt_getsv_interp();
+	XSRETURN(1);
+
+void
+my_cxt_setsv(sv)
+    SV *sv;
+    CODE:
+	dMY_CXT;
+	SvREFCNT_dec(MY_CXT.sv);
+	my_cxt_setsv_p(sv _aMY_CXT);
+	SvREFCNT_inc(sv);
+
+bool
+sv_setsv_cow_hashkey_core()
+
+bool
+sv_setsv_cow_hashkey_notcore()
+
+void
+BEGIN()
+    CODE:
+	sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
+
+void
+CHECK()
+    CODE:
+	sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
+
+void
+UNITCHECK()
+    CODE:
+	sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
+
+void
+INIT()
+    CODE:
+	sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
+
+void
+END()
+    CODE:
+	sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
diff --git a/blead-maint-fixup/ext/XS/APItest/MANIFEST b/blead-maint-fixup/ext/XS/APItest/MANIFEST
new file mode 100644
index 0000000..a8cfd5f
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/MANIFEST
@@ -0,0 +1,10 @@
+Makefile.PL
+MANIFEST
+README
+APItest.pm
+APItest.xs
+exception.c
+t/call.t
+t/hash.t
+t/printf.t
+t/push.t
diff --git a/blead-maint-fixup/ext/XS/APItest/Makefile.PL b/blead-maint-fixup/ext/XS/APItest/Makefile.PL
new file mode 100644
index 0000000..05bcfb0
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/Makefile.PL
@@ -0,0 +1,31 @@
+use 5.008;
+use ExtUtils::MakeMaker;
+use ExtUtils::Constant 0.11 'WriteConstants';
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+    'NAME'		=> 'XS::APItest',
+    'VERSION_FROM'	=> 'APItest.pm', # finds $VERSION
+    'PREREQ_PM'		=> {}, # e.g., Module::Name => 1.1
+    ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
+      (ABSTRACT_FROM => 'APItest.pm', # retrieve abstract from module
+       AUTHOR     => 'Tim Jenness <t.jenness@jach.hawaii.edu>, Christian Soeller <csoelle@mph.auckland.ac.nz>, Hugo van der Sanden <hv@crypt.compulink.co.uk>') : ()),
+    'C'                 => ['exception.c', 'core.c', 'notcore.c'],
+    'OBJECT'            => '$(BASEEXT)$(OBJ_EXT) $(O_FILES)',
+    'LIBS'		=> [''], # e.g., '-lm'
+    'DEFINE'		=> '', # e.g., '-DHAVE_SOMETHING'
+    'INC'		=> '-I.', # e.g., '-I. -I/usr/include/other'
+	# Un-comment this if you add C files to link with later:
+    # 'OBJECT'		=> '$(O_FILES)', # link all the C files too
+    MAN3PODS		=> {},  # Pods will be built by installman.
+    realclean => {FILES	=> 'const-c.inc const-xs.inc'},
+);
+
+WriteConstants(
+    PROXYSUBS => 1,
+    NAME => 'XS::APItest',
+    NAMES => [qw(HV_DELETE HV_DISABLE_UVAR_XKEY G_DISCARD HV_FETCH_ISSTORE
+		 HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV)],
+);
+
+sub MY::install { "install ::\n"  };
diff --git a/blead-maint-fixup/ext/XS/APItest/README b/blead-maint-fixup/ext/XS/APItest/README
new file mode 100644
index 0000000..cdbf449
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/README
@@ -0,0 +1,20 @@
+XS::APItest version 0.01
+========================
+
+This module is used to test that the Perl C API is working correctly.
+It is not meant to be installed.
+
+Currently tests that printf formatting works correctly.
+
+DEPENDENCIES
+
+None.
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2002 Tim Jenness, Christian Soeller and Hugo van der Sanden.
+All Rights Reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. 
+
diff --git a/blead-maint-fixup/ext/XS/APItest/core.c b/blead-maint-fixup/ext/XS/APItest/core.c
new file mode 100644
index 0000000..39192b0
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/core.c
@@ -0,0 +1,2 @@
+#define PERL_CORE
+#include "core_or_not.inc"
diff --git a/blead-maint-fixup/ext/XS/APItest/core_or_not.inc b/blead-maint-fixup/ext/XS/APItest/core_or_not.inc
new file mode 100644
index 0000000..8fa3234
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/core_or_not.inc
@@ -0,0 +1,44 @@
+/* This code is compiled twice, once with -DPERL_CORE defined, once without */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef PERL_CORE
+#  define SUFFIX core
+#else
+#  define SUFFIX notcore
+#endif
+
+bool
+CAT2(sv_setsv_cow_hashkey_, SUFFIX) () {
+    dTHX;
+    SV *source = newSVpvn_share("pie", 3, 0);
+    SV *destination = newSV(0);
+    bool result;
+
+    if(!SvREADONLY(source) && !SvFAKE(source)) {
+	SvREFCNT_dec(source);
+	Perl_croak(aTHX_ "Creating a shared hash key scalar failed when "
+	       STRINGIFY(SUFFIX) " got flags %"UVxf, (UV)SvFLAGS(source));
+    }
+
+    sv_setsv(destination, source);
+
+    result = SvREADONLY(destination) && SvFAKE(destination);
+
+    SvREFCNT_dec(source);
+    SvREFCNT_dec(destination);
+
+    return result;
+}
+
+/*
+ * Local variables:
+ * mode: c
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/blead-maint-fixup/ext/XS/APItest/exception.c b/blead-maint-fixup/ext/XS/APItest/exception.c
new file mode 100644
index 0000000..01ff912
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/exception.c
@@ -0,0 +1,37 @@
+#include "EXTERN.h"
+#include "perl.h"
+
+#define NO_XSLOCKS
+#include "XSUB.h"
+
+static void throws_exception(int throw_e)
+{
+  if (throw_e)
+    croak("boo\n");
+}
+
+/* Don't give this the same name as exection() in ext/Devel/PPPort/module3.c
+   as otherwise building entirely staticly will cause a test to fail, as
+   PPPort's execption() gets used in place of this one.  */
+   
+int apitest_exception(int throw_e)
+{
+  dTHR;
+  dXCPT;
+  SV *caught = get_sv("XS::APItest::exception_caught", 0);
+
+  XCPT_TRY_START {
+    throws_exception(throw_e);
+  } XCPT_TRY_END
+
+  XCPT_CATCH
+  {
+    sv_setiv(caught, 1);
+    XCPT_RETHROW;
+  }
+
+  sv_setiv(caught, 0);
+
+  return 42;
+}
+
diff --git a/blead-maint-fixup/ext/XS/APItest/notcore.c b/blead-maint-fixup/ext/XS/APItest/notcore.c
new file mode 100644
index 0000000..9e19d8a
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/notcore.c
@@ -0,0 +1,2 @@
+#undef PERL_CORE
+#include "core_or_not.inc"
diff --git a/blead-maint-fixup/ext/XS/APItest/t/call.t b/blead-maint-fixup/ext/XS/APItest/t/call.t
new file mode 100644
index 0000000..b4facd7
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/call.t
@@ -0,0 +1,174 @@
+#!perl -w
+
+# test the various call-into-perl-from-C functions
+# DAPM Aug 2004
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+	# Look, I'm using this fully-qualified variable more than once!
+	my $arch = $MacPerl::Architecture;
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use warnings;
+use strict;
+
+# Test::More doesn't have fresh_perl_is() yet
+# use Test::More tests => 240;
+
+BEGIN {
+    require './test.pl';
+    plan(240);
+    use_ok('XS::APItest')
+};
+
+#########################
+
+sub f {
+    shift;
+    unshift @_, 'b';
+    pop @_;
+    @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
+}
+
+sub d {
+    no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
+    die "its_dead_jim\n";
+}
+
+my $obj = bless [], 'Foo';
+
+sub Foo::meth {
+    return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
+    shift;
+    shift;
+    unshift @_, 'b';
+    pop @_;
+    @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
+}
+
+sub Foo::d {
+    no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
+    die "its_dead_jim\n";
+}
+
+for my $test (
+    # flags      args           expected         description
+    [ G_VOID,    [ ],           [ qw(z 1) ],     '0 args, G_VOID' ],
+    [ G_VOID,    [ qw(a p q) ], [ qw(z 1) ],     '3 args, G_VOID' ],
+    [ G_SCALAR,  [ ],           [ qw(y 1) ],     '0 args, G_SCALAR' ],
+    [ G_SCALAR,  [ qw(a p q) ], [ qw(y 1) ],     '3 args, G_SCALAR' ],
+    [ G_ARRAY,   [ ],           [ qw(x 1) ],     '0 args, G_ARRAY' ],
+    [ G_ARRAY,   [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
+    [ G_DISCARD, [ ],           [ qw(0) ],       '0 args, G_DISCARD' ],
+    [ G_DISCARD, [ qw(a p q) ], [ qw(0) ],       '3 args, G_DISCARD' ],
+)
+{
+    my ($flags, $args, $expected, $description) = @$test;
+
+    ok(eq_array( [ call_sv(\&f, $flags, @$args) ], $expected),
+	"$description call_sv(\\&f)");
+
+    ok(eq_array( [ call_sv(*f,  $flags, @$args) ], $expected),
+	"$description call_sv(*f)");
+
+    ok(eq_array( [ call_sv('f', $flags, @$args) ], $expected),
+	"$description call_sv('f')");
+
+    ok(eq_array( [ call_pv('f', $flags, @$args) ], $expected),
+	"$description call_pv('f')");
+
+    ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
+	$expected), "$description eval_sv('f(args)')");
+
+    ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected),
+	"$description call_method('meth')");
+
+    for my $keep (0, G_KEEPERR) {
+	my $desc = $description . ($keep ? ' G_KEEPERR' : '');
+	my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n"
+			    : "its_dead_jim\n";
+	$@ = "before\n";
+	ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
+		    $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
+		    "$desc G_EVAL call_sv('d')");
+	is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
+
+	$@ = "before\n";
+	ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], 
+		    $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
+		    "$desc G_EVAL call_pv('d')");
+	is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
+
+	$@ = "before\n";
+	ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
+		    $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
+		    "$desc eval_sv('d()')");
+	is($@, $exp_err, "$desc eval_sv('d()') - \$@");
+
+	$@ = "before\n";
+	ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
+		    $flags & (G_ARRAY|G_DISCARD) ? [0] : [ undef, 1 ]),
+		    "$desc G_EVAL call_method('d')");
+	is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
+    }
+
+    ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
+	$expected), "$description G_NOARGS call_sv('f')");
+
+    ok(eq_array( [ sub { call_pv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
+	$expected), "$description G_NOARGS call_pv('f')");
+
+    ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
+	$expected), "$description G_NOARGS eval_sv('f(@_)')");
+
+    # XXX call_method(G_NOARGS) isn't tested: I'm assuming
+    # it's not a sensible combination. DAPM.
+
+    ok(eq_array( [ eval { call_sv('d', $flags, @$args)}, $@ ],
+	[ "its_dead_jim\n" ]), "$description eval { call_sv('d') }");
+
+    ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
+	[ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
+
+    ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
+	[ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1),
+		"its_dead_jim\n", '' ]),
+	"$description eval { eval_sv('d') }");
+
+    ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
+	[ "its_dead_jim\n" ]), "$description eval { call_method('d') }");
+
+};
+
+is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
+is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
+is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
+is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
+is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
+is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
+
+# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
+# a new jump level but before pushing an eval context, leading to
+# stack corruption
+
+fresh_perl_is(<<'EOF', "x=2", { switches => ['-T'] }, 'eval_sv() taint');
+use XS::APItest;
+
+my $x = 0;
+sub f {
+    eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
+    $x++;
+    $a <=> $b;
+}
+
+eval { my @a = sort f 2, 1;  $x++};
+print "x=$x\n";
+EOF
+
diff --git a/blead-maint-fixup/ext/XS/APItest/t/exception.t b/blead-maint-fixup/ext/XS/APItest/t/exception.t
new file mode 100644
index 0000000..2ac7132
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/exception.t
@@ -0,0 +1,41 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 12;
+
+BEGIN { use_ok('XS::APItest') };
+
+#########################
+
+my $rv;
+
+$XS::APItest::exception_caught = undef;
+
+$rv = eval { apitest_exception(0) };
+is($@, '');
+ok(defined $rv);
+is($rv, 42);
+is($XS::APItest::exception_caught, 0);
+
+$XS::APItest::exception_caught = undef;
+
+$rv = eval { apitest_exception(1) };
+is($@, "boo\n");
+ok(not defined $rv);
+is($XS::APItest::exception_caught, 1);
+
+$rv = eval { mycroak("foobar\n"); 1 };
+is($@, "foobar\n", 'croak');
+ok(not defined $rv);
+
+$rv = eval { $@ = bless{}, "foo"; mycroak(undef); 1 };
+is(ref($@), "foo", 'croak(NULL)');
+ok(not defined $rv);
diff --git a/blead-maint-fixup/ext/XS/APItest/t/hash.t b/blead-maint-fixup/ext/XS/APItest/t/hash.t
new file mode 100644
index 0000000..13bbd9c
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/hash.t
@@ -0,0 +1,432 @@
+#!perl -w
+
+BEGIN {
+  chdir 't' if -d 't';
+  @INC = '../lib';
+  push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+  require Config; import Config;
+  if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+    # Look, I'm using this fully-qualified variable more than once!
+    my $arch = $MacPerl::Architecture;
+    print "1..0 # Skip: XS::APItest was not built\n";
+    exit 0;
+  }
+}
+
+use strict;
+use utf8;
+use Tie::Hash;
+use Test::More 'no_plan';
+
+BEGIN {use_ok('XS::APItest')};
+
+sub preform_test;
+sub test_present;
+sub test_absent;
+sub test_delete_present;
+sub test_delete_absent;
+sub brute_force_exists;
+sub test_store;
+sub test_fetch_present;
+sub test_fetch_absent;
+
+my $utf8_for_258 = chr 258;
+utf8::encode $utf8_for_258;
+
+my @testkeys = ('N', chr 198, chr 256);
+my @keys = (@testkeys, $utf8_for_258);
+
+foreach (@keys) {
+  utf8::downgrade $_, 1;
+}
+main_tests (\@keys, \@testkeys, '');
+
+foreach (@keys) {
+  utf8::upgrade $_;
+}
+main_tests (\@keys, \@testkeys, ' [utf8 hash]');
+
+{
+  my %h = (a=>'cheat');
+  tie %h, 'Tie::StdHash';
+  is (XS::APItest::Hash::store(\%h, chr 258,  1), undef);
+    
+  ok (!exists $h{$utf8_for_258},
+      "hv_store doesn't insert a key with the raw utf8 on a tied hash");
+}
+
+{
+    my $strtab = strtab();
+    is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
+    my $wibble = "\0";
+    eval {
+	$strtab->{$wibble}++;
+    };
+    my $prefix = "Cannot modify shared string table in hv_";
+    my $what = $prefix . 'fetch';
+    like ($@, qr/^$what/,$what);
+    eval {
+	XS::APItest::Hash::store($strtab, 'Boom!',  1)
+    };
+    $what = $prefix . 'store';
+    like ($@, qr/^$what/, $what);
+    if (0) {
+	A::B->method();
+    }
+    # DESTROY should be in there.
+    eval {
+	delete $strtab->{DESTROY};
+    };
+    $what = $prefix . 'delete';
+    like ($@, qr/^$what/, $what);
+    # I can't work out how to get to the code that flips the wasutf8 flag on
+    # the hash key without some ikcy XS
+}
+
+{
+    is_deeply([&XS::APItest::Hash::test_hv_free_ent], [2,2,1,1],
+	      "hv_free_ent frees the value immediately");
+    is_deeply([&XS::APItest::Hash::test_hv_delayfree_ent], [2,2,2,1],
+	      "hv_delayfree_ent keeps the value around until FREETMPS");
+}
+
+foreach my $in ("", "N", "a\0b") {
+    my $got = XS::APItest::Hash::test_share_unshare_pvn($in);
+    is ($got, $in, "test_share_unshare_pvn");
+}
+
+if ($] > 5.009) {
+    foreach ([\&XS::APItest::Hash::rot13_hash, \&rot13, "rot 13"],
+	     [\&XS::APItest::Hash::bitflip_hash, \&bitflip, "bitflip"],
+	    ) {
+	my ($setup, $mapping, $name) = @$_;
+	my %hash;
+	my %placebo = (a => 1, p => 2, i => 4, e => 8);
+	$setup->(\%hash);
+	$hash{a}++; @hash{qw(p i e)} = (2, 4, 8);
+
+	test_U_hash(\%hash, \%placebo, [f => 9, g => 10, h => 11], $mapping,
+		    $name);
+    }
+    foreach my $upgrade_o (0, 1) {
+	foreach my $upgrade_n (0, 1) {
+	    my (%hash, %placebo);
+	    XS::APItest::Hash::bitflip_hash(\%hash);
+	    foreach my $new (["7", 65, 67, 80],
+			     ["8", 163, 171, 215],
+			     ["U", 2603, 2604, 2604],
+			    ) {
+		foreach my $code (78, 240, 256, 1336) {
+		    my $key = chr $code;
+		    # This is the UTF-8 byte sequence for the key.
+		    my $key_utf8 = $key;
+		    utf8::encode($key_utf8);
+		    if ($upgrade_o) {
+			$key .= chr 256;
+			chop $key;
+		    }
+		    $hash{$key} = $placebo{$key} = $code;
+		    $hash{$key_utf8} = $placebo{$key_utf8} = "$code as UTF-8";
+		}
+		my $name = 'bitflip ' . shift @$new;
+		my @new_kv;
+		foreach my $code (@$new) {
+		    my $key = chr $code;
+		    if ($upgrade_n) {
+			$key .= chr 256;
+			chop $key;
+		    }
+		    push @new_kv, $key, $_;
+		}
+
+		$name .= ' upgraded(orig) ' if $upgrade_o;
+		$name .= ' upgraded(new) ' if $upgrade_n;
+		test_U_hash(\%hash, \%placebo, \@new_kv, \&bitflip, $name);
+	    }
+	}
+    }
+}
+
+exit;
+
+################################   The End   ################################
+
+sub test_U_hash {
+    my ($hash, $placebo, $new, $mapping, $message) = @_;
+    my @hitlist = keys %$placebo;
+    print "# $message\n";
+
+    my @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
+	"uvar magic called exactly once on store");
+
+    is (keys %$hash, keys %$placebo);
+
+    my $victim = shift @hitlist;
+    is (delete $hash->{$victim}, delete $placebo->{$victim});
+
+    is (keys %$hash, keys %$placebo);
+    @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
+
+    $victim = shift @hitlist;
+    is (XS::APItest::Hash::delete_ent ($hash, $victim,
+				       XS::APItest::HV_DISABLE_UVAR_XKEY),
+	undef, "Deleting a known key with conversion disabled fails (ent)");
+    is (keys %$hash, keys %$placebo);
+
+    is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
+	delete $placebo->{$victim},
+	"Deleting a known key with conversion enabled works (ent)");
+    is (keys %$hash, keys %$placebo);
+    @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
+
+    $victim = shift @hitlist;
+    is (XS::APItest::Hash::delete ($hash, $victim,
+				   XS::APItest::HV_DISABLE_UVAR_XKEY),
+	undef, "Deleting a known key with conversion disabled fails");
+    is (keys %$hash, keys %$placebo);
+
+    is (XS::APItest::Hash::delete ($hash, $victim, 0),
+	delete $placebo->{$victim},
+	"Deleting a known key with conversion enabled works");
+    is (keys %$hash, keys %$placebo);
+    @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
+
+    my ($k, $v) = splice @$new, 0, 2;
+    $hash->{$k} = $v;
+    $placebo->{$k} = $v;
+    is (keys %$hash, keys %$placebo);
+    @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
+
+    ($k, $v) = splice @$new, 0, 2;
+    is (XS::APItest::Hash::store_ent($hash, $k, $v), $v, "store_ent");
+    $placebo->{$k} = $v;
+    is (keys %$hash, keys %$placebo);
+    @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
+
+    ($k, $v) = splice @$new, 0, 2;
+    is (XS::APItest::Hash::store($hash, $k, $v), $v, "store");
+    $placebo->{$k} = $v;
+    is (keys %$hash, keys %$placebo);
+    @keys = sort keys %$hash;
+    is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
+
+    @hitlist = keys %$placebo;
+    $victim = shift @hitlist;
+    is (XS::APItest::Hash::fetch_ent($hash, $victim), $placebo->{$victim},
+	"fetch_ent");
+    is (XS::APItest::Hash::fetch_ent($hash, $mapping->($victim)), undef,
+	"fetch_ent (missing)");
+
+    $victim = shift @hitlist;
+    is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
+	"fetch");
+    is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
+	"fetch (missing)");
+
+    $victim = shift @hitlist;
+    ok (XS::APItest::Hash::exists_ent($hash, $victim), "exists_ent");
+    ok (!XS::APItest::Hash::exists_ent($hash, $mapping->($victim)),
+	"exists_ent (missing)");
+
+    $victim = shift @hitlist;
+    die "Need a victim" unless defined $victim;
+    ok (XS::APItest::Hash::exists($hash, $victim), "exists");
+    ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
+	"exists (missing)");
+
+    is (XS::APItest::Hash::common({hv => $hash, keysv => $victim}),
+	$placebo->{$victim}, "common (fetch)");
+    is (XS::APItest::Hash::common({hv => $hash, keypv => $victim}),
+	$placebo->{$victim}, "common (fetch pv)");
+    is (XS::APItest::Hash::common({hv => $hash, keysv => $victim,
+				   action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
+	undef, "common (fetch) missing");
+    is (XS::APItest::Hash::common({hv => $hash, keypv => $victim,
+				   action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
+	undef, "common (fetch pv) missing");
+    is (XS::APItest::Hash::common({hv => $hash, keysv => $mapping->($victim),
+				   action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
+	$placebo->{$victim}, "common (fetch) missing mapped");
+    is (XS::APItest::Hash::common({hv => $hash, keypv => $mapping->($victim),
+				   action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
+	$placebo->{$victim}, "common (fetch pv) missing mapped");
+}
+
+sub main_tests {
+  my ($keys, $testkeys, $description) = @_;
+  foreach my $key (@$testkeys) {
+    my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
+    my $unikey = $key;
+    utf8::encode $unikey;
+
+    utf8::downgrade $key, 1;
+    utf8::downgrade $lckey, 1;
+    utf8::downgrade $unikey, 1;
+    main_test_inner ($key, $lckey, $unikey, $keys, $description);
+
+    utf8::upgrade $key;
+    utf8::upgrade $lckey;
+    utf8::upgrade $unikey;
+    main_test_inner ($key, $lckey, $unikey, $keys,
+		     $description . ' [key utf8 on]');
+  }
+
+  # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
+  # used - the utf8 flag was being lost.
+  perform_test (\&test_absent, (chr 258), $keys, '');
+
+  perform_test (\&test_fetch_absent, (chr 258), $keys, '');
+  perform_test (\&test_delete_absent, (chr 258), $keys, '');
+}
+
+sub main_test_inner {
+  my ($key, $lckey, $unikey, $keys, $description) = @_;
+  perform_test (\&test_present, $key, $keys, $description);
+  perform_test (\&test_fetch_present, $key, $keys, $description);
+  perform_test (\&test_delete_present, $key, $keys, $description);
+
+  perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
+  perform_test (\&test_store, $key, $keys, $description, []);
+
+  perform_test (\&test_absent, $lckey, $keys, $description);
+  perform_test (\&test_fetch_absent, $lckey, $keys, $description);
+  perform_test (\&test_delete_absent, $lckey, $keys, $description);
+
+  return if $unikey eq $key;
+
+  perform_test (\&test_absent, $unikey, $keys, $description);
+  perform_test (\&test_fetch_absent, $unikey, $keys, $description);
+  perform_test (\&test_delete_absent, $unikey, $keys, $description);
+}
+
+sub perform_test {
+  my ($test_sub, $key, $keys, $message, @other) = @_;
+  my $printable = join ',', map {ord} split //, $key;
+
+  my (%hash, %tiehash);
+  tie %tiehash, 'Tie::StdHash';
+
+  @hash{@$keys} = @$keys;
+  @tiehash{@$keys} = @$keys;
+
+  &$test_sub (\%hash, $key, $printable, $message, @other);
+  &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
+}
+
+sub test_present {
+  my ($hash, $key, $printable, $message) = @_;
+
+  ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
+  ok (XS::APItest::Hash::exists ($hash, $key),
+      "hv_exists present$message $printable");
+}
+
+sub test_absent {
+  my ($hash, $key, $printable, $message) = @_;
+
+  ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
+  ok (!XS::APItest::Hash::exists ($hash, $key),
+      "hv_exists absent$message $printable");
+}
+
+sub test_delete_present {
+  my ($hash, $key, $printable, $message) = @_;
+
+  my $copy = {};
+  my $class = tied %$hash;
+  if (defined $class) {
+    tie %$copy, ref $class;
+  }
+  $copy = {%$hash};
+  ok (brute_force_exists ($copy, $key),
+      "hv_delete_ent present$message $printable");
+  is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
+  ok (!brute_force_exists ($copy, $key),
+      "hv_delete_ent present$message $printable");
+  $copy = {%$hash};
+  ok (brute_force_exists ($copy, $key),
+      "hv_delete present$message $printable");
+  is (XS::APItest::Hash::delete ($copy, $key), $key,
+      "hv_delete present$message $printable");
+  ok (!brute_force_exists ($copy, $key),
+      "hv_delete present$message $printable");
+}
+
+sub test_delete_absent {
+  my ($hash, $key, $printable, $message) = @_;
+
+  my $copy = {};
+  my $class = tied %$hash;
+  if (defined $class) {
+    tie %$copy, ref $class;
+  }
+  $copy = {%$hash};
+  is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
+  $copy = {%$hash};
+  is (XS::APItest::Hash::delete ($copy, $key), undef,
+      "hv_delete absent$message $printable");
+}
+
+sub test_store {
+  my ($hash, $key, $printable, $message, $defaults) = @_;
+  my $HV_STORE_IS_CRAZY = 1;
+
+  # We are cheating - hv_store returns NULL for a store into an empty
+  # tied hash. This isn't helpful here.
+
+  my $class = tied %$hash;
+
+  my %h1 = @$defaults;
+  my %h2 = @$defaults;
+  if (defined $class) {
+    tie %h1, ref $class;
+    tie %h2, ref $class;
+    $HV_STORE_IS_CRAZY = undef;
+  }
+  is (XS::APItest::Hash::store_ent(\%h1, $key, 1), $HV_STORE_IS_CRAZY,
+      "hv_store_ent$message $printable"); 
+  ok (brute_force_exists (\%h1, $key), "hv_store_ent$message $printable");
+  is (XS::APItest::Hash::store(\%h2, $key,  1), $HV_STORE_IS_CRAZY,
+      "hv_store$message $printable");
+  ok (brute_force_exists (\%h2, $key), "hv_store$message $printable");
+}
+
+sub test_fetch_present {
+  my ($hash, $key, $printable, $message) = @_;
+
+  is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
+  is (XS::APItest::Hash::fetch ($hash, $key), $key,
+      "hv_fetch present$message $printable");
+}
+
+sub test_fetch_absent {
+  my ($hash, $key, $printable, $message) = @_;
+
+  is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
+  is (XS::APItest::Hash::fetch ($hash, $key), undef,
+      "hv_fetch absent$message $printable");
+}
+
+sub brute_force_exists {
+  my ($hash, $key) = @_;
+  foreach (keys %$hash) {
+    return 1 if $key eq $_;
+  }
+  return 0;
+}
+
+sub rot13 {
+    my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
+    wantarray ? @results : $results[0];
+}
+
+sub bitflip {
+    my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
+    wantarray ? @results : $results[0];
+}
diff --git a/blead-maint-fixup/ext/XS/APItest/t/my_cxt.t b/blead-maint-fixup/ext/XS/APItest/t/my_cxt.t
new file mode 100644
index 0000000..2c34794
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/my_cxt.t
@@ -0,0 +1,57 @@
+#!perl -w
+
+# test per-interpeter static data API (MY_CXT)
+# DAPM Dec 2005
+
+my $threads;
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+	# Look, I'm using this fully-qualified variable more than once!
+	my $arch = $MacPerl::Architecture;
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+    $threads = $Config{'useithreads'};
+    # must 'use threads' before 'use Test::More'
+    eval 'use threads' if $threads;
+}
+
+use warnings;
+use strict;
+
+use Test::More tests => 11;
+
+BEGIN {
+    use_ok('XS::APItest');
+};
+
+is(my_cxt_getint(), 99, "initial int value");
+is(my_cxt_getsv(),  "initial", "initial SV value");
+
+my_cxt_setint(1234);
+is(my_cxt_getint(), 1234, "new int value");
+
+my_cxt_setsv("abcd");
+is(my_cxt_getsv(),  "abcd", "new SV value");
+
+sub do_thread {
+    is(my_cxt_getint(), 1234, "initial int value (child)");
+    my_cxt_setint(4321);
+    is(my_cxt_getint(), 4321, "new int value (child)");
+
+    is(my_cxt_getsv(), "initial_clone", "initial sv value (child)");
+    my_cxt_setsv("dcba");
+    is(my_cxt_getsv(),  "dcba", "new SV value (child)");
+}
+
+SKIP: {
+    skip "No threads", 4 unless $threads;
+    threads->create(\&do_thread)->join;
+}
+
+is(my_cxt_getint(), 1234,  "int value preserved after join");
+is(my_cxt_getsv(),  "abcd", "SV value preserved after join");
diff --git a/blead-maint-fixup/ext/XS/APItest/t/op.t b/blead-maint-fixup/ext/XS/APItest/t/op.t
new file mode 100644
index 0000000..29a6409
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/op.t
@@ -0,0 +1,25 @@
+#!perl -w
+
+BEGIN {
+  chdir 't' if -d 't';
+  @INC = '../lib';
+  push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+  require Config; import Config;
+  if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+    # Look, I'm using this fully-qualified variable more than once!
+    my $arch = $MacPerl::Architecture;
+    print "1..0 # Skip: XS::APItest was not built\n";
+    exit 0;
+  }
+}
+
+use strict;
+use utf8;
+use Test::More 'no_plan';
+
+use_ok('XS::APItest');
+
+*hint_exists = *hint_exists = \&XS::APItest::Hash::refcounted_he_exists;
+*hint_fetch = *hint_fetch = \&XS::APItest::Hash::refcounted_he_fetch;
+
+require './op/caller.pl';
diff --git a/blead-maint-fixup/ext/XS/APItest/t/printf.t b/blead-maint-fixup/ext/XS/APItest/t/printf.t
new file mode 100644
index 0000000..ef2769e
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/printf.t
@@ -0,0 +1,56 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 11;
+
+BEGIN { use_ok('XS::APItest') };
+
+#########################
+
+my $ldok = have_long_double();
+
+# first some IO redirection
+ok open(my $oldout, ">&STDOUT"), "saving STDOUT";
+ok open(STDOUT, '>', "foo.out"),"redirecting STDOUT";
+
+# Allow for it to be removed
+END { unlink "foo.out"; };
+
+select STDOUT; $| = 1; # make unbuffered
+
+# Run the printf tests
+print_double(5);
+print_int(3);
+print_long(4);
+print_float(4);
+print_long_double() if $ldok;  # val=7 hardwired
+
+print_flush();
+
+# Now redirect STDOUT and read from the file
+ok open(STDOUT, ">&", $oldout), "restore STDOUT";
+ok open(my $foo, "<foo.out"), "open foo.out";
+#print "# Test output by reading from file\n";
+# now test the output
+my @output = map { chomp; $_ } <$foo>;
+close $foo;
+ok @output >= 4, "captured at least four output lines";
+
+is($output[0], "5.000", "print_double");
+is($output[1], "3", "print_int");
+is($output[2], "4", "print_long");
+is($output[3], "4.000", "print_float");
+
+SKIP: {
+   skip "No long doubles", 1 unless $ldok;
+   is($output[4], "7.000", "print_long_double");
+}
+
diff --git a/blead-maint-fixup/ext/XS/APItest/t/push.t b/blead-maint-fixup/ext/XS/APItest/t/push.t
new file mode 100644
index 0000000..66d442e
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/push.t
@@ -0,0 +1,34 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 9;
+
+BEGIN { use_ok('XS::APItest') };
+
+#########################
+
+my @mpushp = mpushp();
+my @mpushn = mpushn();
+my @mpushi = mpushi();
+my @mpushu = mpushu();
+ok(eq_array(\@mpushp, [qw(one two three)]), 'mPUSHp()');
+ok(eq_array(\@mpushn, [0.5, -0.25, 0.125]), 'mPUSHn()');
+ok(eq_array(\@mpushi, [-1, 2, -3]),         'mPUSHi()');
+ok(eq_array(\@mpushu, [1, 2, 3]),           'mPUSHu()');
+
+my @mxpushp = mxpushp();
+my @mxpushn = mxpushn();
+my @mxpushi = mxpushi();
+my @mxpushu = mxpushu();
+ok(eq_array(\@mxpushp, [qw(one two three)]), 'mXPUSHp()');
+ok(eq_array(\@mxpushn, [0.5, -0.25, 0.125]), 'mXPUSHn()');
+ok(eq_array(\@mxpushi, [-1, 2, -3]),         'mXPUSHi()');
+ok(eq_array(\@mxpushu, [1, 2, 3]),           'mXPUSHu()');
diff --git a/blead-maint-fixup/ext/XS/APItest/t/svsetsv.t b/blead-maint-fixup/ext/XS/APItest/t/svsetsv.t
new file mode 100644
index 0000000..0d938f8
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/svsetsv.t
@@ -0,0 +1,25 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+BEGIN { use_ok('XS::APItest') };
+
+# I can't see a good way to easily get back perl-space diagnostics for these
+# I hope that this isn't a problem.
+ok(sv_setsv_cow_hashkey_core,
+   "With PERL_CORE sv_setsv does COW for shared hash key scalars");
+
+ok(!sv_setsv_cow_hashkey_notcore,
+   "Without PERL_CORE sv_setsv doesn't COW for shared hash key scalars");
diff --git a/blead-maint-fixup/ext/XS/APItest/t/xs_special_subs.t b/blead-maint-fixup/ext/XS/APItest/t/xs_special_subs.t
new file mode 100644
index 0000000..9283093
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/xs_special_subs.t
@@ -0,0 +1,159 @@
+#!perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+    # Hush the used only once warning.
+    $XS::APItest::WARNINGS_ON_BOOTSTRAP = $MacPerl::Architecture;
+    $XS::APItest::WARNINGS_ON_BOOTSTRAP = 1;
+}
+
+use strict;
+use warnings;
+use Test::More tests => 100;
+
+# Doing this longhand cut&paste makes it clear
+# BEGIN and INIT are FIFO, CHECK and END are LIFO
+BEGIN {
+    print "# First BEGIN\n";
+    is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+    is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+    is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not yet called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not yet called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+CHECK {
+    print "# First CHECK\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+INIT {
+    print "# First INIT\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+END {
+    print "# First END\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
+    is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::INIT_called_PP, 1, "INIT called");
+    is($XS::APItest::END_called, 1, "END called");
+    is($XS::APItest::END_called_PP, 1, "END called");
+}
+
+print "# First body\n";
+is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+is($XS::APItest::CHECK_called, 1, "CHECK called");
+is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
+is($XS::APItest::INIT_called, 1, "INIT called");
+is($XS::APItest::INIT_called_PP, 1, "INIT called");
+is($XS::APItest::END_called, undef, "END not yet called");
+is($XS::APItest::END_called_PP, undef, "END not yet called");
+
+use XS::APItest;
+
+print "# Second body\n";
+is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+is($XS::APItest::CHECK_called, 1, "CHECK called");
+is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
+is($XS::APItest::INIT_called, 1, "INIT called");
+is($XS::APItest::INIT_called_PP, 1, "INIT called");
+is($XS::APItest::END_called, undef, "END not yet called");
+is($XS::APItest::END_called_PP, undef, "END not yet called");
+
+BEGIN {
+    print "# Second BEGIN\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not yet called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+CHECK {
+    print "# Second CHECK\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK yet called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK yet called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not yet called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+INIT {
+    print "# Second INIT\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
+    is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::INIT_called_PP, 1, "INIT called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+END {
+    print "# Second END\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
+    is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::INIT_called_PP, 1, "INIT called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
diff --git a/blead-maint-fixup/ext/XS/APItest/t/xs_special_subs_require.t b/blead-maint-fixup/ext/XS/APItest/t/xs_special_subs_require.t
new file mode 100644
index 0000000..b868f33
--- /dev/null
+++ b/blead-maint-fixup/ext/XS/APItest/t/xs_special_subs_require.t
@@ -0,0 +1,167 @@
+#!perl -w
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+    # Hush the used only once warning.
+    $XS::APItest::WARNINGS_ON_BOOTSTRAP = $MacPerl::Architecture;
+    $XS::APItest::WARNINGS_ON_BOOTSTRAP = 1;
+}
+
+use strict;
+use warnings;
+use Test::More tests => 103;
+
+# Doing this longhand cut&paste makes it clear
+# BEGIN and INIT are FIFO, CHECK and END are LIFO
+BEGIN {
+    print "# First BEGIN\n";
+    is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+    is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+    is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not called");
+    is($XS::APItest::INIT_called, undef, "INIT not called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+CHECK {
+    print "# First CHECK\n";
+    is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+    is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+    is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not called (too late)");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not called (too late)");
+    is($XS::APItest::INIT_called, undef, "INIT not called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+INIT {
+    print "# First INIT\n";
+    is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+    is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+    is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not called (too late)");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not called (too late)");
+    is($XS::APItest::INIT_called, undef, "INIT not called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+END {
+    print "# First END\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not called (too late)");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not called (too late)");
+    is($XS::APItest::INIT_called, undef, "INIT not called (too late)");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not called (too late)");
+    is($XS::APItest::END_called, 1, "END called");
+    is($XS::APItest::END_called_PP, 1, "END called");
+}
+
+print "# First body\n";
+is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not called");
+is($XS::APItest::CHECK_called, undef, "CHECK not called (too late)");
+is($XS::APItest::CHECK_called_PP, undef, "CHECK not called (too late)");
+is($XS::APItest::INIT_called, undef, "INIT not called (too late)");
+is($XS::APItest::INIT_called_PP, undef, "INIT not called (too late)");
+is($XS::APItest::END_called, undef, "END not yet called");
+is($XS::APItest::END_called_PP, undef, "END not yet called");
+
+{
+    my @trap;
+    local $SIG{__WARN__} = sub { push @trap, join "!", @_ };
+    require XS::APItest;
+
+    @trap = sort @trap;
+    is(scalar @trap, 2, "There were 2 warnings");
+    is($trap[0], "Too late to run CHECK block.\n");
+    is($trap[1], "Too late to run INIT block.\n");
+}
+
+print "# Second body\n";
+is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+is($XS::APItest::CHECK_called, undef, "CHECK not called (too late)");
+is($XS::APItest::CHECK_called_PP, undef, "CHECK not called (too late)");
+is($XS::APItest::INIT_called, undef, "INIT not called (too late)");
+is($XS::APItest::INIT_called_PP, undef, "INIT not called (too late)");
+is($XS::APItest::END_called, undef, "END not yet called");
+is($XS::APItest::END_called_PP, undef, "END not yet called");
+
+BEGIN {
+    print "# Second BEGIN\n";
+    is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+    is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+    is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not called");
+    is($XS::APItest::INIT_called, undef, "INIT not called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+CHECK {
+    print "# Second CHECK\n";
+    is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+    is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+    is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not yet called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not called");
+    is($XS::APItest::INIT_called, undef, "INIT not called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+INIT {
+    print "# Second INIT\n";
+    is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+    is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+    is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not yet called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not called (too late)");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not called (too late)");
+    is($XS::APItest::INIT_called, undef, "INIT not called (too late)");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not called (too late)");
+    is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
+}
+
+END {
+    print "# Second END\n";
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not called (too late)");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not called (too late)");
+    is($XS::APItest::INIT_called, undef, "INIT not called (too late)");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not called (too late)");
+    is($XS::APItest::END_called, 1, "END called");
+    is($XS::APItest::END_called_PP, 1, "END called");
+}