In perl.git, the branch smueller/typemapdocs4 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/39f4ee03071aeb70244888a22b7d0f48e8a21054?hp=5cb04c0d7922e6628753edb374c8aa780e5dc6bd>
- Log ----------------------------------------------------------------- commit 39f4ee03071aeb70244888a22b7d0f48e8a21054 Author: Steffen Mueller <[email protected]> Date: Tue Jan 24 08:24:00 2012 +0100 XS::Typemap: Tests for T_PACKED M ext/XS-Typemap/Typemap.pm M ext/XS-Typemap/Typemap.xs M ext/XS-Typemap/t/Typemap.t commit e2591dfd04ec63a6b7c1564e4ce4cdfd75420a78 Author: Steffen Mueller <[email protected]> Date: Mon Jan 23 18:33:26 2012 +0100 Document T_PACKEDARRAY M ext/XS-Typemap/Typemap.xs ----------------------------------------------------------------------- Summary of changes: ext/XS-Typemap/Typemap.pm | 1 + ext/XS-Typemap/Typemap.xs | 98 +++++++++++++++++++++++++++++++++++++++++++- ext/XS-Typemap/t/Typemap.t | 12 ++++- 3 files changed, 106 insertions(+), 5 deletions(-) diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm index 84c50e8..dee185b 100644 --- a/ext/XS-Typemap/Typemap.pm +++ b/ext/XS-Typemap/Typemap.pm @@ -75,6 +75,7 @@ $VERSION = '0.08'; T_OPAQUEPTR_IN_struct T_OPAQUEPTR_OUT_struct T_ARRAY T_STDIO_open T_STDIO_close T_STDIO_print + T_PACKED_in T_PACKED_out /); XSLoader::load(); diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs index f53f84a..1b33b5b 100644 --- a/ext/XS-Typemap/Typemap.xs +++ b/ext/XS-Typemap/Typemap.xs @@ -31,7 +31,7 @@ typedef short shortOPQ; /* T_OPAQUE */ typedef int intOpq; /* T_OPAQUEPTR */ typedef unsigned intUnsigned; /* T_U_INT */ -/* A structure to test T_OPAQUEPTR */ +/* A structure to test T_OPAQUEPTR and T_PACKED */ struct t_opaqueptr { int a; int b; @@ -39,6 +39,7 @@ struct t_opaqueptr { }; typedef struct t_opaqueptr astruct; +typedef struct t_opaqueptr anotherstruct; /* Some static memory for the tests */ static I32 xst_anint; @@ -63,6 +64,52 @@ intArray * intArrayPtr( int nelem ) { return array; } +/* test T_PACKED */ +#define XS_pack_anotherstructPtr(out, in) \ + STMT_START { \ + HV *hash = newHV(); \ + hv_stores(hash, "a", newSViv((in)->a)); \ + hv_stores(hash, "b", newSViv((in)->b)); \ + hv_stores(hash, "c", newSVnv((in)->c)); \ + sv_setsv((out), sv_2mortal(newRV_noinc((SV*)hash))); \ + } STMT_END + +static anotherstruct * +XS_unpack_anotherstructPtr(SV *in) +{ + dTHX; /* rats, this is expensive */ + /* this is similar to T_HVREF since we chose to use a hash */ + HV *inhash; + SV **elem; + anotherstruct *out; + SV *const tmp = in; + SvGETMAGIC(tmp); + if (SvROK(tmp) && SvTYPE(SvRV(tmp)) == SVt_PVHV) + inhash = (HV*)SvRV(tmp); + else + Perl_croak(aTHX_ "Argument is not a HASH reference"); + + /* FIXME dunno if supposed to use perl mallocs here */ + Newxz(out, 1, anotherstruct); + + elem = hv_fetchs(inhash, "a", 0); + if (elem == NULL) + Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL"); + out->a = SvIV(*elem); + + elem = hv_fetchs(inhash, "b", 0); + if (elem == NULL) + Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL"); + out->b = SvIV(*elem); + + elem = hv_fetchs(inhash, "c", 0); + if (elem == NULL) + Perl_croak(aTHX_ "Shouldn't happen: hv_fetchs returns NULL"); + out->c = SvNV(*elem); + + return out; +} + MODULE = XS::Typemap PACKAGE = XS::Typemap @@ -92,6 +139,7 @@ intTLONG T_LONG shortOPQ T_OPAQUE shortOPQ * T_OPAQUEPTR astruct * T_OPAQUEPTR +anotherstruct * T_PACKED AV_FIXED * T_AVREF_REFCOUNT_FIXED HV_FIXED * T_HVREF_REFCOUNT_FIXED CV_FIXED * T_CVREF_REFCOUNT_FIXED @@ -1038,6 +1086,7 @@ C<foo_t *> might be: static void XS_pack_foo_tPtr(SV *out, foo_t *in) { + dTHX; /* alas, signature does not include pTHX_ */ HV* hash = newHV(); hv_stores(hash, "int_member", newSViv(in->int_member)); hv_stores(hash, "float_member", newSVnv(in->float_member)); @@ -1053,9 +1102,54 @@ but the prototype would be: static foo_t * XS_unpack_foo_tPtr(SV *in); +Instead of an actual C function that has to fetch the thread context +using C<dTHX>, you can define macros of the same name and avoid the +overhead. Also, keep in mind to possibly free the memory allocated by +C<XS_unpack_foo_tPtr>. + +=cut + +void +T_PACKED_in(in) + anotherstruct *in; + PPCODE: + mXPUSHi(in->a); + mXPUSHi(in->b); + mXPUSHn(in->c); + Safefree(in); + XSRETURN(3); + +anotherstruct * +T_PACKED_out(a, b ,c) + int a; + int b; + double c; + CODE: + Newxz(RETVAL, 1, anotherstruct); + RETVAL->a = a; + RETVAL->b = b; + RETVAL->c = c; + OUTPUT: RETVAL + CLEANUP: + Safefree(RETVAL); + =item T_PACKEDARRAY -NOT YET +T_PACKEDARRAY is similar to T_PACKED. In fact, the C<INPUT> (Perl +to XSUB) typemap is indentical, but the C<OUTPUT> typemap passes +an additional argument to the C<XS_pack_$ntype> function. This +third parameter indicates the number of elements in the output +so that the function can handle C arrays sanely. The variable +needs to be declared by the user and must have the name +C<count_$ntype> where C<$ntype> is the normalized C type name +as explained above. The signature of the function would be for +the example above and C<foo_t **>: + + static void + XS_pack_foo_tPtrPtr(SV *out, foo_t *in, UV count_foo_tPtrPtr); + +The type of the third parameter is arbitrary as far as the typemap +is concerned. It just has to be in line with the declared variable. =item T_DATAUNIT diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t index ed3aea6..d2a0d3e 100644 --- a/ext/XS-Typemap/t/Typemap.t +++ b/ext/XS-Typemap/t/Typemap.t @@ -6,7 +6,7 @@ BEGIN { } } -use Test::More tests => 102; +use Test::More tests => 105; use strict; use warnings; @@ -269,7 +269,7 @@ is(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR is(T_OPAQUE_OUT( $p ), $t ); # Test using T_OPQAQUE # T_OPAQUE_array -note("A packed array"); +note("T_OPAQUE: A packed array"); my @opq = (2,4,8); my $packed = T_OPAQUE_array(@opq); @@ -279,7 +279,13 @@ for (0..$#opq) { is( $uopq[$_], $opq[$_]); } -# Skip T_PACKED +# T_PACKED +note("T_PACKED"); +my $struct = T_PACKED_out(-4, 3, 2.1); +ok(ref($struct) eq 'HASH'); +is_deeply($struct, {a => -4, b => 3, c => 2.1}); +my @rv = T_PACKED_in($struct); +is_deeply(\@rv, [-4, 3, 2.1]); # Skip T_PACKEDARRAY -- Perl5 Master Repository
