dist/ExtUtils-ParseXS/t/517-t-targetable.t

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use Carp;
   5 use Cwd;
   6 use File::Spec;
   7 use Test::More;
   8 use lib qw( lib );
   9 use ExtUtils::Typemaps;
  10
  11 my $output_expr_ref = {
  12   'T_CALLBACK' => '     sv_setpvn($arg, $var.context.value().chp(),
  13                 $var.context.value().size());
  14 ',
  15   'T_OUT' => '  {
  16             GV *gv = newGVgen("$Package");
  17             if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
  18                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
  19             else
  20                 $arg = &PL_sv_undef;
  21         }
  22 ',
  23   'T_REF_IV_PTR' => '   sv_setref_pv($arg, \\"${ntype}\\", (void*)$var);
  24 ',
  25   'T_U_LONG' => '       sv_setuv($arg, (UV)$var);
  26 ',
  27   'T_U_CHAR' => '       sv_setuv($arg, (UV)$var);
  28 ',
  29   'T_U_INT' => '        sv_setuv($arg, (UV)$var);
  30 ',
  31   'T_ARRAY' => '        {
  32             U32 ix_$var;
  33             EXTEND(SP,size_$var);
  34             for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
  35                 ST(ix_$var) = sv_newmortal();
  36         DO_ARRAY_ELEM
  37             }
  38         }
  39 ',
  40   'T_NV' => '   sv_setnv($arg, (NV)$var);
  41 ',
  42   'T_SHORT' => '        sv_setiv($arg, (IV)$var);
  43 ',
  44   'T_OPAQUE' => '       sv_setpvn($arg, (char *)&$var, sizeof($var));
  45 ',
  46   'T_PTROBJ' => '       sv_setref_pv($arg, \\"${ntype}\\", (void*)$var);
  47 ',
  48   'T_HVREF' => '        $arg = newRV((SV*)$var);
  49 ',
  50   'T_PACKEDARRAY' => '  XS_pack_$ntype($arg, $var, count_$ntype);
  51 ',
  52   'T_INT' => '  sv_setiv($arg, (IV)$var);
  53 ',
  54   'T_OPAQUEPTR' => '    sv_setpvn($arg, (char *)$var, sizeof(*$var));
  55 ',
  56   'T_BOOL' => ' $arg = boolSV($var);
  57 ',
  58   'T_REFREF' => '       NOT_IMPLEMENTED
  59 ',
  60   'T_REF_IV_REF' => '   sv_setref_pv($arg, \\"${ntype}\\", (void*)new $ntype($var));
  61 ',
  62   'T_STDIO' => '        {
  63             GV *gv = newGVgen("$Package");
  64             PerlIO *fp = PerlIO_importFILE($var,0);
  65             if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
  66                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
  67             else
  68                 $arg = &PL_sv_undef;
  69         }
  70 ',
  71   'T_FLOAT' => '        sv_setnv($arg, (double)$var);
  72 ',
  73   'T_IN' => '   {
  74             GV *gv = newGVgen("$Package");
  75             if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
  76                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
  77             else
  78                 $arg = &PL_sv_undef;
  79         }
  80 ',
  81   'T_PV' => '   sv_setpv((SV*)$arg, $var);
  82 ',
  83   'T_INOUT' => '        {
  84             GV *gv = newGVgen("$Package");
  85             if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
  86                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
  87             else
  88                 $arg = &PL_sv_undef;
  89         }
  90 ',
  91   'T_CHAR' => ' sv_setpvn($arg, (char *)&$var, 1);
  92 ',
  93   'T_LONG' => ' sv_setiv($arg, (IV)$var);
  94 ',
  95   'T_DOUBLE' => '       sv_setnv($arg, (double)$var);
  96 ',
  97   'T_PTR' => '  sv_setiv($arg, PTR2IV($var));
  98 ',
  99   'T_AVREF' => '        $arg = newRV((SV*)$var);
 100 ',
 101   'T_SV' => '   $arg = $var;
 102 ',
 103   'T_ENUM' => ' sv_setiv($arg, (IV)$var);
 104 ',
 105   'T_REFOBJ' => '       NOT IMPLEMENTED
 106 ',
 107   'T_CVREF' => '        $arg = newRV((SV*)$var);
 108 ',
 109   'T_UV' => '   sv_setuv($arg, (UV)$var);
 110 ',
 111   'T_PACKED' => '       XS_pack_$ntype($arg, $var);
 112 ',
 113   'T_SYSRET' => '       if ($var != -1) {
 114             if ($var == 0)
 115                 sv_setpvn($arg, "0 but true", 10);
 116             else
 117                 sv_setiv($arg, (IV)$var);
 118         }
 119 ',
 120   'T_IV' => '   sv_setiv($arg, (IV)$var);
 121 ',
 122   'T_PTRDESC' => '      sv_setref_pv($arg, \\"${ntype}\\", (void*)new\\U${type}_DESC\\E($var));
 123 ',
 124   'T_DATAUNIT' => '     sv_setpvn($arg, $var.chp(), $var.size());
 125 ',
 126   'T_U_SHORT' => '      sv_setuv($arg, (UV)$var);
 127 ',
 128   'T_SVREF' => '        $arg = newRV((SV*)$var);
 129 ',
 130   'T_PTRREF' => '       sv_setref_pv($arg, Nullch, (void*)$var);
 131 ',
 132 };
 133
 134 plan tests => scalar(keys %$output_expr_ref);
 135
 136 my %results = (
 137   T_UV        => { type => 'u', with_size => undef, what => '(UV)$var', what_size => undef },
 138   T_IV        => { type => 'i', with_size => undef, what => '(IV)$var', what_size => undef },
 139   T_NV        => { type => 'n', with_size => undef, what => '(NV)$var', what_size => undef },
 140   T_FLOAT     => { type => 'n', with_size => undef, what => '(double)$var', what_size => undef },
 141   T_PTR       => { type => 'i', with_size => undef, what => 'PTR2IV($var)', what_size => undef },
 142   T_PV        => { type => 'p', with_size => undef, what => '$var', what_size => undef },
 143   T_OPAQUE    => { type => 'p', with_size => 'n', what => '(char *)&$var', what_size => ', sizeof($var)' },
 144   T_OPAQUEPTR => { type => 'p', with_size => 'n', what => '(char *)$var', what_size => ', sizeof(*$var)' },
 145   T_CHAR      => { type => 'p', with_size => 'n', what => '(char *)&$var', what_size => ', 1' },
 146   T_CALLBACK  => { type => 'p', with_size => 'n', what => '$var.context.value().chp()',
 147                    what_size => ",\n            \$var.context.value().size()" }, # whitespace is significant here
 148   T_DATAUNIT  => { type => 'p', with_size => 'n', what => '$var.chp()', what_size => ', $var.size()' },
 149 );
 150
 151 $results{$_} = $results{T_UV} for qw(T_U_LONG T_U_INT T_U_CHAR T_U_SHORT);
 152 $results{$_} = $results{T_IV} for qw(T_LONG T_INT T_SHORT T_ENUM);
 153 $results{$_} = $results{T_FLOAT} for qw(T_DOUBLE);
 154
 155 foreach my $xstype (sort keys %$output_expr_ref) {
 156   my $om = ExtUtils::Typemaps::OutputMap->new(
 157     xstype => $xstype,
 158     code => $output_expr_ref->{$xstype}
 159   );
 160   my $targetable = $om->targetable;
 161   if (not exists($results{$xstype})) {
 162     ok(not(defined($targetable)), "$xstype not targetable")
 163       or diag(join ", ", map {defined($_) ? $_ : "<undef>"} %$targetable);
 164   }
 165   else {
 166     my $res = $results{$xstype};
 167     is_deeply($targetable, $res, "$xstype targetable and has right output")
 168       or diag(join ", ", map {defined($_) ? $_ : "<undef>"} %$targetable);
 169   }
 170 }
 171