This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix XS types in typemap in order to deal with references with get magics correctly
[perl5.git] / lib / ExtUtils / typemap
1 # basic C types
2 int                     T_IV
3 unsigned                T_UV
4 unsigned int            T_UV
5 long                    T_IV
6 unsigned long           T_UV
7 short                   T_IV
8 unsigned short          T_UV
9 char                    T_CHAR
10 unsigned char           T_U_CHAR
11 char *                  T_PV
12 unsigned char *         T_PV
13 const char *            T_PV
14 caddr_t                 T_PV
15 wchar_t *               T_PV
16 wchar_t                 T_IV
17 # bool_t is defined in <rpc/rpc.h>
18 bool_t                  T_IV
19 size_t                  T_UV
20 ssize_t                 T_IV
21 time_t                  T_NV
22 unsigned long *         T_OPAQUEPTR
23 char **                 T_PACKEDARRAY
24 void *                  T_PTR
25 Time_t *                T_PV
26 SV *                    T_SV
27 SVREF                   T_SVREF
28 AV *                    T_AVREF
29 HV *                    T_HVREF
30 CV *                    T_CVREF
31
32 IV                      T_IV
33 UV                      T_UV
34 NV                      T_NV
35 I32                     T_IV
36 I16                     T_IV
37 I8                      T_IV
38 STRLEN                  T_UV
39 U32                     T_U_LONG
40 U16                     T_U_SHORT
41 U8                      T_UV
42 Result                  T_U_CHAR
43 Boolean                 T_BOOL
44 float                   T_FLOAT
45 double                  T_DOUBLE
46 SysRet                  T_SYSRET
47 SysRetLong              T_SYSRET
48 FILE *                  T_STDIO
49 PerlIO *                T_INOUT
50 FileHandle              T_PTROBJ
51 InputStream             T_IN
52 InOutStream             T_INOUT
53 OutputStream            T_OUT
54 bool                    T_BOOL
55
56 #############################################################################
57 INPUT
58 T_SV
59         $var = $arg
60 T_SVREF
61         STMT_START {
62                 SV* const xsub_tmp_sv = $arg;
63                 SvGETMAGIC(xsub_tmp_sv);
64                 if (SvROK(xsub_tmp_sv)){
65                     $var = SvRV(xsub_tmp_sv);
66                 }
67                 else{
68                     Perl_croak(aTHX_ \"%s: %s is not a reference\",
69                                 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
70                                 \"$var\");
71                 }
72         } STMT_END
73 T_AVREF
74         STMT_START {
75                 SV* const xsub_tmp_sv = $arg;
76                 SvGETMAGIC(xsub_tmp_sv);
77                 if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
78                     $var = (AV*)SvRV(xsub_tmp_sv);
79                 }
80                 else{
81                     Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\",
82                                 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
83                                 \"$var\");
84                 }
85         } STMT_END
86 T_HVREF
87         STMT_START {
88                 SV* const xsub_tmp_sv = $arg;
89                 SvGETMAGIC(xsub_tmp_sv);
90                 if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
91                     $var = (AV*)SvRV(xsub_tmp_sv);
92                 }
93                 else{
94                     Perl_croak(aTHX_ \"%s: %s is not a HASH reference\",
95                                 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
96                                 \"$var\");
97                 }
98         } STMT_END
99 T_CVREF
100         STMT_START {
101                 SV* const xsub_tmp_sv = $arg;
102                 SvGETMAGIC(xsub_tmp_sv);
103                 if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){
104                     $var = (AV*)SvRV(xsub_tmp_sv);
105                 }
106                 else{
107                     Perl_croak(aTHX_ \"%s: %s is not a CODE reference\",
108                                 ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
109                                 \"$var\");
110                 }
111         } STMT_END
112 T_SYSRET
113         $var NOT IMPLEMENTED
114 T_UV
115         $var = ($type)SvUV($arg)
116 T_IV
117         $var = ($type)SvIV($arg)
118 T_INT
119         $var = (int)SvIV($arg)
120 T_ENUM
121         $var = ($type)SvIV($arg)
122 T_BOOL
123         $var = (bool)SvTRUE($arg)
124 T_U_INT
125         $var = (unsigned int)SvUV($arg)
126 T_SHORT
127         $var = (short)SvIV($arg)
128 T_U_SHORT
129         $var = (unsigned short)SvUV($arg)
130 T_LONG
131         $var = (long)SvIV($arg)
132 T_U_LONG
133         $var = (unsigned long)SvUV($arg)
134 T_CHAR
135         $var = (char)*SvPV_nolen($arg)
136 T_U_CHAR
137         $var = (unsigned char)SvUV($arg)
138 T_FLOAT
139         $var = (float)SvNV($arg)
140 T_NV
141         $var = ($type)SvNV($arg)
142 T_DOUBLE
143         $var = (double)SvNV($arg)
144 T_PV
145         $var = ($type)SvPV_nolen($arg)
146 T_PTR
147         $var = INT2PTR($type,SvIV($arg))
148 T_PTRREF
149         if (SvROK($arg)) {
150             IV tmp = SvIV((SV*)SvRV($arg));
151             $var = INT2PTR($type,tmp);
152         }
153         else
154             Perl_croak(aTHX_ \"%s: %s is not a reference\",
155                         ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
156                         \"$var\")
157 T_REF_IV_REF
158         if (sv_isa($arg, \"${ntype}\")) {
159             IV tmp = SvIV((SV*)SvRV($arg));
160             $var = *INT2PTR($type *, tmp);
161         }
162         else
163             Perl_croak(aTHX_ \"%s: %s is not of type %s\",
164                         ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
165                         \"$var\", \"$ntype\")
166 T_REF_IV_PTR
167         if (sv_isa($arg, \"${ntype}\")) {
168             IV tmp = SvIV((SV*)SvRV($arg));
169             $var = INT2PTR($type, tmp);
170         }
171         else
172             Perl_croak(aTHX_ \"%s: %s is not of type %s\",
173                         ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
174                         \"$var\", \"$ntype\")
175 T_PTROBJ
176         if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) {
177             IV tmp = SvIV((SV*)SvRV($arg));
178             $var = INT2PTR($type,tmp);
179         }
180         else
181             Perl_croak(aTHX_ \"%s: %s is not of type %s\",
182                         ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
183                         \"$var\", \"$ntype\")
184 T_PTRDESC
185         if (sv_isa($arg, \"${ntype}\")) {
186             IV tmp = SvIV((SV*)SvRV($arg));
187             ${type}_desc = (\U${type}_DESC\E*) tmp;
188             $var = ${type}_desc->ptr;
189         }
190         else
191             Perl_croak(aTHX_ \"%s: %s is not of type %s\",
192                         ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
193                         \"$var\", \"$ntype\")
194 T_REFREF
195         if (SvROK($arg)) {
196             IV tmp = SvIV((SV*)SvRV($arg));
197             $var = *INT2PTR($type,tmp);
198         }
199         else
200             Perl_croak(aTHX_ \"%s: %s is not a reference\",
201                         ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
202                         \"$var\")
203 T_REFOBJ
204         if (sv_isa($arg, \"${ntype}\")) {
205             IV tmp = SvIV((SV*)SvRV($arg));
206             $var = *INT2PTR($type,tmp);
207         }
208         else
209             Perl_croak(aTHX_ \"%s: %s is not of type %s\",
210                         ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
211                         \"$var\", \"$ntype\")
212 T_OPAQUE
213         $var = *($type *)SvPV_nolen($arg)
214 T_OPAQUEPTR
215         $var = ($type)SvPV_nolen($arg)
216 T_PACKED
217         $var = XS_unpack_$ntype($arg)
218 T_PACKEDARRAY
219         $var = XS_unpack_$ntype($arg)
220 T_CALLBACK
221         $var = make_perl_cb_$type($arg)
222 T_ARRAY
223         U32 ix_$var = $argoff;
224         $var = $ntype(items -= $argoff);
225         while (items--) {
226             DO_ARRAY_ELEM;
227             ix_$var++;
228         }
229         /* this is the number of elements in the array */
230         ix_$var -= $argoff
231 T_STDIO
232         $var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
233 T_IN
234         $var = IoIFP(sv_2io($arg))
235 T_INOUT
236         $var = IoIFP(sv_2io($arg))
237 T_OUT
238         $var = IoOFP(sv_2io($arg))
239 #############################################################################
240 OUTPUT
241 T_SV
242         $arg = $var;
243 T_SVREF
244         $arg = newRV((SV*)$var);
245 T_AVREF
246         $arg = newRV((SV*)$var);
247 T_HVREF
248         $arg = newRV((SV*)$var);
249 T_CVREF
250         $arg = newRV((SV*)$var);
251 T_IV
252         sv_setiv($arg, (IV)$var);
253 T_UV
254         sv_setuv($arg, (UV)$var);
255 T_INT
256         sv_setiv($arg, (IV)$var);
257 T_SYSRET
258         if ($var != -1) {
259             if ($var == 0)
260                 sv_setpvn($arg, "0 but true", 10);
261             else
262                 sv_setiv($arg, (IV)$var);
263         }
264 T_ENUM
265         sv_setiv($arg, (IV)$var);
266 T_BOOL
267         $arg = boolSV($var);
268 T_U_INT
269         sv_setuv($arg, (UV)$var);
270 T_SHORT
271         sv_setiv($arg, (IV)$var);
272 T_U_SHORT
273         sv_setuv($arg, (UV)$var);
274 T_LONG
275         sv_setiv($arg, (IV)$var);
276 T_U_LONG
277         sv_setuv($arg, (UV)$var);
278 T_CHAR
279         sv_setpvn($arg, (char *)&$var, 1);
280 T_U_CHAR
281         sv_setuv($arg, (UV)$var);
282 T_FLOAT
283         sv_setnv($arg, (double)$var);
284 T_NV
285         sv_setnv($arg, (NV)$var);
286 T_DOUBLE
287         sv_setnv($arg, (double)$var);
288 T_PV
289         sv_setpv((SV*)$arg, $var);
290 T_PTR
291         sv_setiv($arg, PTR2IV($var));
292 T_PTRREF
293         sv_setref_pv($arg, Nullch, (void*)$var);
294 T_REF_IV_REF
295         sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var));
296 T_REF_IV_PTR
297         sv_setref_pv($arg, \"${ntype}\", (void*)$var);
298 T_PTROBJ
299         sv_setref_pv($arg, \"${ntype}\", (void*)$var);
300 T_PTRDESC
301         sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
302 T_REFREF
303         NOT_IMPLEMENTED
304 T_REFOBJ
305         NOT IMPLEMENTED
306 T_OPAQUE
307         sv_setpvn($arg, (char *)&$var, sizeof($var));
308 T_OPAQUEPTR
309         sv_setpvn($arg, (char *)$var, sizeof(*$var));
310 T_PACKED
311         XS_pack_$ntype($arg, $var);
312 T_PACKEDARRAY
313         XS_pack_$ntype($arg, $var, count_$ntype);
314 T_DATAUNIT      
315         sv_setpvn($arg, $var.chp(), $var.size());
316 T_CALLBACK
317         sv_setpvn($arg, $var.context.value().chp(),
318                 $var.context.value().size());
319 T_ARRAY
320         {
321             U32 ix_$var;
322             EXTEND(SP,size_$var);
323             for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
324                 ST(ix_$var) = sv_newmortal();
325         DO_ARRAY_ELEM
326             }
327         }
328 T_STDIO
329         {
330             GV *gv = newGVgen("$Package");
331             PerlIO *fp = PerlIO_importFILE($var,0);
332             if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
333                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
334             else
335                 $arg = &PL_sv_undef;
336         }
337 T_IN
338         {
339             GV *gv = newGVgen("$Package");
340             if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
341                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
342             else
343                 $arg = &PL_sv_undef;
344         }
345 T_INOUT
346         {
347             GV *gv = newGVgen("$Package");
348             if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
349                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
350             else
351                 $arg = &PL_sv_undef;
352         }
353 T_OUT
354         {
355             GV *gv = newGVgen("$Package");
356             if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
357                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
358             else
359                 $arg = &PL_sv_undef;
360         }