diff options
author | Steffen Mueller <smueller@cpan.org> | 2011-07-12 22:02:24 +0200 |
---|---|---|
committer | Steffen Mueller <smueller@cpan.org> | 2011-07-12 22:02:26 +0200 |
commit | bb17296d8de7c33dc13da5d17077dd5140a794b1 (patch) | |
tree | 97c258357dd2052c3c6f2aff9bde09339cb42130 /dist/ExtUtils-ParseXS/t/107-make_targetable.t | |
parent | 17616481cf4701b926ec5adcc5914f839cfa0c2e (diff) | |
parent | 96893281c6f796153cd1c238c56581fa7c8c802a (diff) | |
download | perl-bb17296d8de7c33dc13da5d17077dd5140a794b1.tar.gz |
Merge branch 'smueller/eu_typemap' into blead
Much of ExtUtils::ParseXS was rewritten and cleaned up.
It has been made somewhat more extensible and now finally
uses strictures.
The logic for parsing, merging, and dumping XS typemaps was extracted
from ExtUtils::ParseXS into a module of its own, ExtUtils::Typemaps.
ExtUtils::Typemaps offers an interface to typemap handling outside of
the scope of the XS compiler itself.
As a first use case of the improved API an extensibility, typemaps can now
be included inline into XS code with a HEREDOC-like syntax:
TYPEMAP: <<END_TYPEMAP
MyType T_IV
END_TYPEMAP
Diffstat (limited to 'dist/ExtUtils-ParseXS/t/107-make_targetable.t')
-rw-r--r-- | dist/ExtUtils-ParseXS/t/107-make_targetable.t | 146 |
1 files changed, 146 insertions, 0 deletions
diff --git a/dist/ExtUtils-ParseXS/t/107-make_targetable.t b/dist/ExtUtils-ParseXS/t/107-make_targetable.t new file mode 100644 index 0000000000..fde608f4e0 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/107-make_targetable.t @@ -0,0 +1,146 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More qw(no_plan); # tests => 7; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + make_targetable +); + +my $output_expr_ref = { + 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), + $var.context.value().size()); +', + 'T_OUT' => ' { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +', + 'T_REF_IV_PTR' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)$var); +', + 'T_U_LONG' => ' sv_setuv($arg, (UV)$var); +', + 'T_U_CHAR' => ' sv_setuv($arg, (UV)$var); +', + 'T_U_INT' => ' sv_setuv($arg, (UV)$var); +', + 'T_ARRAY' => ' { + U32 ix_$var; + EXTEND(SP,size_$var); + for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { + ST(ix_$var) = sv_newmortal(); + DO_ARRAY_ELEM + } + } +', + 'T_NV' => ' sv_setnv($arg, (NV)$var); +', + 'T_SHORT' => ' sv_setiv($arg, (IV)$var); +', + 'T_OPAQUE' => ' sv_setpvn($arg, (char *)&$var, sizeof($var)); +', + 'T_PTROBJ' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)$var); +', + 'T_HVREF' => ' $arg = newRV((SV*)$var); +', + 'T_PACKEDARRAY' => ' XS_pack_$ntype($arg, $var, count_$ntype); +', + 'T_INT' => ' sv_setiv($arg, (IV)$var); +', + 'T_OPAQUEPTR' => ' sv_setpvn($arg, (char *)$var, sizeof(*$var)); +', + 'T_BOOL' => ' $arg = boolSV($var); +', + 'T_REFREF' => ' NOT_IMPLEMENTED +', + 'T_REF_IV_REF' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)new $ntype($var)); +', + 'T_STDIO' => ' { + GV *gv = newGVgen("$Package"); + PerlIO *fp = PerlIO_importFILE($var,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +', + 'T_FLOAT' => ' sv_setnv($arg, (double)$var); +', + 'T_IN' => ' { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +', + 'T_PV' => ' sv_setpv((SV*)$arg, $var); +', + 'T_INOUT' => ' { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +', + 'T_CHAR' => ' sv_setpvn($arg, (char *)&$var, 1); +', + 'T_LONG' => ' sv_setiv($arg, (IV)$var); +', + 'T_DOUBLE' => ' sv_setnv($arg, (double)$var); +', + 'T_PTR' => ' sv_setiv($arg, PTR2IV($var)); +', + 'T_AVREF' => ' $arg = newRV((SV*)$var); +', + 'T_SV' => ' $arg = $var; +', + 'T_ENUM' => ' sv_setiv($arg, (IV)$var); +', + 'T_REFOBJ' => ' NOT IMPLEMENTED +', + 'T_CVREF' => ' $arg = newRV((SV*)$var); +', + 'T_UV' => ' sv_setuv($arg, (UV)$var); +', + 'T_PACKED' => ' XS_pack_$ntype($arg, $var); +', + 'T_SYSRET' => ' if ($var != -1) { + if ($var == 0) + sv_setpvn($arg, "0 but true", 10); + else + sv_setiv($arg, (IV)$var); + } +', + 'T_IV' => ' sv_setiv($arg, (IV)$var); +', + 'T_PTRDESC' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)new\\U${type}_DESC\\E($var)); +', + 'T_DATAUNIT' => ' sv_setpvn($arg, $var.chp(), $var.size()); +', + 'T_U_SHORT' => ' sv_setuv($arg, (UV)$var); +', + 'T_SVREF' => ' $arg = newRV((SV*)$var); +', + 'T_PTRREF' => ' sv_setref_pv($arg, Nullch, (void*)$var); +', +}; + +my %targetable; +%targetable = make_targetable($output_expr_ref); + +ok(! exists $targetable{'T_AVREF'}, + "Element found in 'output_expr' not found in \%targetable: not an 'sv_set'" ); + +ok(exists $targetable{'T_CALLBACK'}, + "Element found in 'output_expr' found in \%targetable as expected" ); + +pass("Passed all tests in $0"); |