+++ /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