Commit | Line | Data |
---|---|---|
42dec8cf S |
1 | #!/usr/bin/perl |
2 | use strict; | |
3 | use warnings; | |
4 | use Carp; | |
5 | use Cwd; | |
6 | use File::Spec; | |
42dec8cf S |
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 |