can't yet be merged to blead beacuse of the code freeze for 5.10.
For now, XS::APItest
p4raw-id: //depot/perl@32480
--- /dev/null
+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
--- /dev/null
+#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));
--- /dev/null
+Makefile.PL
+MANIFEST
+README
+APItest.pm
+APItest.xs
+exception.c
+t/call.t
+t/hash.t
+t/printf.t
+t/push.t
--- /dev/null
+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" };
--- /dev/null
+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.
+
--- /dev/null
+#define PERL_CORE
+#include "core_or_not.inc"
--- /dev/null
+/* 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:
+ */
--- /dev/null
+#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;
+}
+
--- /dev/null
+#undef PERL_CORE
+#include "core_or_not.inc"
--- /dev/null
+#!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
+
--- /dev/null
+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);
--- /dev/null
+#!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];
+}
--- /dev/null
+#!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");
--- /dev/null
+#!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';
--- /dev/null
+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");
+}
+
--- /dev/null
+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()');
--- /dev/null
+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");
--- /dev/null
+#!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");
+}
--- /dev/null
+#!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");
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff