1#!/usr/bin/perl
2use strict;
3use warnings;
4use Carp;
5use Cwd;
6use File::Spec;
7use Test::More;
8use lib qw( lib );
9use ExtUtils::Typemaps;
10
11my $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
134plan tests => scalar(keys %$output_expr_ref);
135
136my %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
155foreach 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
172