summaryrefslogtreecommitdiff
path: root/dist/ExtUtils-ParseXS/t/107-make_targetable.t
diff options
context:
space:
mode:
authorSteffen Mueller <smueller@cpan.org>2011-07-12 22:02:24 +0200
committerSteffen Mueller <smueller@cpan.org>2011-07-12 22:02:26 +0200
commitbb17296d8de7c33dc13da5d17077dd5140a794b1 (patch)
tree97c258357dd2052c3c6f2aff9bde09339cb42130 /dist/ExtUtils-ParseXS/t/107-make_targetable.t
parent17616481cf4701b926ec5adcc5914f839cfa0c2e (diff)
parent96893281c6f796153cd1c238c56581fa7c8c802a (diff)
downloadperl-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.t146
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");