Many changes
[perl-ctypes:perl-ctypes.git] / Ctypes.xs
1 /*###########################################################################
2 ## Name:        Ctypes.xs
3 ## Purpose:     Perl binding to libffi
4 ## Author:      Ryan Jendoubi
5 ## Based on:    FFI.pm, P5NCI.pm
6 ## Created:     2010-05-21
7 ## Copyright:   (c) 2010 Ryan Jendoubi
8 ## Licence:     This program is free software; you can redistribute it and/or
9 ##              modify it under the same terms as Perl itself
10 ###########################################################################*/
11
12 #include "EXTERN.h"
13 #include "perl.h"
14 #include "XSUB.h"
15 #include "ppport.h"
16
17 #include "ffi.h"
18 #include "limits.h"
19 #include "Ctypes.h"
20 #include "src/obj_util.c"
21 #include "src/util.c"
22
23 #include "const-c.inc"
24
25 int
26 ConvArg(SV* obj, char type_expected,
27         ffi_type **argtypes, void **argvalues, int index)
28 {
29   debug_warn("#[%s:%i] In ConvArg...", __FILE__, __LINE__);
30   debug_warn("#    Type expected: %c",type_expected);
31   SV *arg, *tmp;
32   char type, type_got = '\0';
33   STRLEN tc_len = 1;
34
35   if(SvROK(obj) && !sv_isobject(obj)) {
36     tmp = SvRV(obj);
37     obj = tmp;
38     tmp = NULL;
39   }
40
41 /*
42   while( SvROK(obj) && !sv_isobject(obj) ) {
43     if( SvTYPE(SvRV(obj)) == ( SVt_PVAV || SVt_PVHV || SVt_PVCV ) ) {
44       croak("ConvArg error arg[%i]: Only scalars or objects allowed",
45              index );
46     }
47     tmp = SvRV(obj);
48     obj = tmp;
49   }
50 */
51
52   debug_warn("#    Checking type_got...");
53   if( sv_isobject(obj) ) {
54     type_got = (char)*SvPV(Ct_HVObj_GET_ATTR_KEY(obj,"_typecode"),tc_len);
55 //    tmp = Ct_HVObj_GET_ATTR_KEY(obj, "_as_param_");
56 //    if( tmp == NULL || !SvOK(tmp) ) {
57       AV* args = NULL;
58       tmp = Ct_CallPerlObjMethod(obj, "_as_param_", args);
59       if(SvROK(tmp))
60         tmp = SvRV(tmp);
61 //    }
62     if( tmp == NULL )
63       croak("ConvArg: couldn't get _as_param_ data from arg %i", index);
64 //    debug_warn("_as_param_ gave: %i", (((int*)SvPV_nolen(tmp))[2]));
65    /* {_as_param_} will now exist, straight after calling _as_param_() */
66     obj = tmp;
67   } else {
68     type_got = '\0';
69   }
70   debug_warn("#    type_got: %c", type_got);
71
72   if( type_expected )
73     type = type_expected;
74   else if( type_got )
75     type = type_got;
76   else if( SvPOK(obj) )
77     type = 's';
78   else if( SvNOK(obj) )
79     type = 'd';
80   else if( SvIOK(obj) )
81     type = 'i';
82   else
83     croak("ConvArg error: No type information for SV object");
84
85   debug_warn( "#  type %i: %c", index+1, type);
86   argtypes[index] = get_ffi_type(type);
87
88   arg = obj;
89
90   switch(type)
91   {
92   case 'c':
93     Newxc(argvalues[index], 1, char, char);
94     *(char*)argvalues[index] = type_got
95       ? *(char*)SvPVX(arg)
96       : SvIV(arg); 
97     break;
98   case 'C':
99     Newxc(argvalues[index], 1, unsigned char, unsigned char);
100     *(unsigned char*)argvalues[index] = type_got
101       ? *(unsigned char*)SvPVX(arg)
102       : SvIV(arg);
103     break;
104   case 's':
105     Newxc(argvalues[index], 1, short, short);
106     *(short*)argvalues[index] = type_got
107       ? *(short*)SvPVX(arg)
108       : SvIV(arg);
109     break;
110   case 'S':
111     Newxc(argvalues[index], 1, unsigned short, unsigned short);
112     *(unsigned short*)argvalues[index] = type_got
113       ? *(unsigned short*)SvPVX(arg)
114       : SvIV(arg);
115     break;
116   case 'i':
117     Newxc(argvalues[index], 1, int, int);
118     *(int*)argvalues[index] = type_got
119       ? (int)*(intptr_t*)SvPVX(arg)
120       : SvIV(arg);
121     debug_warn("    argvalues[%i] is: %i", index,*(int*)argvalues[index]);
122     break;
123   case 'I':
124     Newxc(argvalues[index], 1, unsigned int, unsigned int);
125     *(unsigned int*)argvalues[index] = type_got
126       ? *(unsigned int*)SvPVX(arg)
127       : SvIV(arg);
128     break;
129   case 'l':
130     Newxc(argvalues[index], 1, long, long);
131     *(long*)argvalues[index] = type_got
132       ? *(long*)SvPVX(arg)
133       : SvIV(arg);
134     break;
135   case 'L':
136     Newxc(argvalues[index], 1, unsigned long, unsigned long);
137     *(unsigned long*)argvalues[index] = type_got
138       ? *(unsigned long*)SvPVX(arg)
139       : SvIV(arg);
140    break;
141   case 'f':
142     Newxc(argvalues[index], 1, float, float);
143     *(float*)argvalues[index] = type_got
144       ? *(float*)SvPVX(arg)
145       : SvNV(arg);
146     break;
147   case 'd':
148     Newxc(argvalues[index], 1, double, double);
149     *(double*)argvalues[index] = type_got
150       ? *(double*)SvPVX(arg)
151       : SvNV(arg);
152     break;
153   case 'D':
154     Newxc(argvalues[index], 1, long double, long double);
155     *(long double*)argvalues[index] = type_got
156       ? *(long double*)SvPVX(arg)
157       : SvNV(arg);
158     break;
159   case 'p':
160     Newx(argvalues[index], 1, void);
161     STRLEN len = sv_len(arg);
162     if(SvIOK(arg)) {
163       debug_warn( "#    [%s:%i] Pointer: SvIOK: assuming 'PTR2IV' value",
164                    __func__, __LINE__ );
165       *(intptr_t*)argvalues[index] = type_got
166         ? (intptr_t)INT2PTR(void*, *(intptr_t*)SvPVX(arg))
167         : (intptr_t)INT2PTR(void*, SvIV(arg));
168     } else {
169       debug_warn( "#    [%s:%i] Pointer: Not SvIOK: assuming 'pack' value",
170                    __func__, __LINE__ );
171       *(intptr_t*)argvalues[index] = (intptr_t)SvPVX(arg);
172     }
173     debug_warn("#    first in argvalues[%i]: %i", index,
174                 *(short*)(*(intptr_t*)argvalues[index])
175               );
176     break;
177   /* should never happen here */
178   default: croak( "ConvArg error: Unrecognised type '%c' (line %i)",
179              type, __LINE__ );
180   }
181   return 0;
182 }
183
184 void
185 _perl_cb_call( ffi_cif* cif, void* retval, void** args, void* udata )
186 {
187     dSP;
188     debug_warn( "\n#[%s:%i] Entered _perl_cb_call...", __FILE__, __LINE__ );
189
190     unsigned int i;
191     int flags = G_SCALAR;
192     unsigned int count = 0;
193     char type;
194     STRLEN len;
195     cb_data_t* data = (cb_data_t*)udata;
196     char* sig = data->sig;
197
198     if( sig[0] == 'v' ) { flags = G_VOID; }
199
200     if( cif->nargs > 0 ) {
201       debug_warn( "#[%s:%i] Have %i args so pushing to stack...",
202                 __FILE__, __LINE__, cif->nargs );
203       ENTER;
204       SAVETMPS;
205
206       PUSHMARK(SP);
207       for( i = 0; i < cif->nargs; i++ ) {
208         type = sig[i+1]; /* sig[0] = return type */
209         debug_warn("This arg type is %c", type);
210         switch (type)
211         {
212           case 'v': break;
213           case 'c': 
214           case 'C': XPUSHs(sv_2mortal(newSViv(*(int*)*(void**)args[i])));   break;
215           case 's': 
216           case 'S':
217               debug_warn( "#    Have type %c, pushing %i to stack...",
218                           type, *(short*)*(void**)args[i] );
219               XPUSHs(sv_2mortal(newSViv((int)*(short*)*(void**)args[i])));   break;
220           case 'i':
221 /*              debug_warn( "#    Have type %c, pushing %i to stack...",
222                           type, *(int*)*(void**)args[i] ); */
223               XPUSHs(sv_2mortal(newSViv(*(int*)*(void**)args[i])));   break;
224           case 'I': XPUSHs(sv_2mortal(newSVuv(*(unsigned int*)*(void**)args[i])));   break;
225           case 'l': XPUSHs(sv_2mortal(newSViv(*(long*)*(void**)args[i])));   break;
226           case 'L': XPUSHs(sv_2mortal(newSVuv(*(unsigned long*)*(void**)args[i])));   break;
227           case 'f': XPUSHs(sv_2mortal(newSVnv(*(float*)*(void**)args[i])));    break;
228           case 'd': XPUSHs(sv_2mortal(newSVnv(*(double*)*(void**)args[i])));    break;
229           case 'D': XPUSHs(sv_2mortal(newSVnv(*(long double*)*(void**)args[i])));    break;
230           case 'p':
231               debug_warn( "#    Have type %c, pushing to stack...",
232                           type );
233               XPUSHs(sv_2mortal(newSVpv((char*)*(void**)args[i], 0))); break;
234         }
235       }
236     PUTBACK;
237     }
238
239     debug_warn( "#[%s:%i] Calling Perl sub...", __FILE__, __LINE__, sig );
240     count = call_sv(data->coderef, G_SCALAR);
241     debug_warn( "#[%s:%i] Returned from Perl sub with %i values", __FILE__, __LINE__, count );
242
243     SPAGAIN;
244
245     if( sig[0] != 'v' ) {
246       if( count != 1 ) {
247         croak( "_perl_cb_call:%i: Expected single %c from Perl callback",
248                __LINE__, sig[0] );
249       }
250       if( count > 1 && sig[0] != 'p' ) {
251        croak( "_perl_cb_call:%i: Received multiple values from Perl \
252 callback; expected %c", __LINE__, sig[0] );
253       }
254       type = sig[0];
255       switch(type)
256       {
257       case 'c':
258         *(char*)retval = POPi;
259         break;
260       case 'C':
261           *(unsigned char*)retval = POPi;
262           break;
263         case 's':
264           *(short*)retval = POPi;
265           break;
266         case 'S':
267           *(unsigned short*)retval = POPi;
268           break;
269         case 'i':
270           *(int*)retval = POPi;
271           debug_warn( "#[%s:%i] retval is %i!", __FILE__, __LINE__, *(int*)retval );
272           break;
273         case 'I':
274           *(int*)retval = POPi;
275           break;
276         case 'l':
277           *(long*)retval = POPl;
278           break;
279         case 'L':
280           *(unsigned long*)retval = POPl;
281          break;
282         case 'f':
283           *(float*)retval = POPn;
284           break;
285         case 'd':
286           *(double*)retval  = POPn;
287           break;
288         case 'D':
289           *(long double*)retval = POPn;
290           break;
291         case 'p':
292           croak( "_perl_cb_call: Returning pointers from Perl subs not yet implemented!" );
293         /*  len = sv_len(SP[0]);
294           debug_warn( "#_perl_cb_call: Got a pointer..." );
295           if(SvIOK(SP[0])) {
296             debug_warn( "#    [%i] SvIOK: assuming 'PTR2IV' value",  __LINE__ );
297             char* thing = POPpx;
298             *(intptr_t*)retval = (intptr_t)INT2PTR(void*, SvIV(ST(i+2)));
299           } else {
300             debug_warn( "#    [%i] Not SvIOK: assuming 'pack' value",  __LINE__ );
301             debug_warn( "#    [%i] sizeof packed array (sv_len): %i",  __LINE__, (int)len );
302             debug_warn( "#    [%i] %i items in array (assumed int)",  __LINE__, (int)((int)len/sizeof(int)) );
303             *(intptr_t*)retval = (intptr_t)SvPVbyte(ST(i+2), len);
304 #ifdef CTYPES_DEBUG
305             int j;
306             for( j = 0; j < ((int)len/sizeof(int)); j++ ) {
307                 debug_warn( "#    argvalues[%i][%i]: %i", i, j, ((int*)*(intptr_t*)retval)[j] );
308             }
309 #endif
310           } */
311           break;
312         /* should never happen here */
313         default: croak( "_perl_cb_call error: Unrecognised type '%c'", type );
314         }        
315     }
316
317     PUTBACK;
318     FREETMPS;
319     LEAVE;
320 }
321     
322 MODULE = Ctypes         PACKAGE = Ctypes
323
324 INCLUDE: const-xs.inc
325
326 #define strictchar char
327
328 void
329 _call( addr, sig, ... )
330     void* addr;
331     strictchar* sig;
332   PROTOTYPE: DISABLE
333   PPCODE:
334     /* PROTOTYPE: $$;@ ? */
335     ffi_cif cif;
336     ffi_status status;
337     ffi_type *rtype;
338     char *rvalue;
339     STRLEN len;
340     unsigned int args_in_sig, rsize;
341     unsigned int num_args = items - 2;
342     ffi_type *argtypes[num_args];
343     void *argvalues[num_args];
344  
345     debug_warn( "\n#[Ctypes.xs: %i ] XS_Ctypes_call_raw( 0x%x, \"%s\", ...)", __LINE__, (unsigned int)(intptr_t)addr, sig );
346     debug_warn( "#Module compiled with -DCTYPES_DEBUG for detailed output from XS" );
347 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
348     if( num_args < 0 ) {
349       croak( "Ctypes::_call error: Not enough arguments" );
350     }
351 #endif
352
353     args_in_sig = validate_signature(sig);
354     if( args_in_sig != num_args ) {
355       croak( "Ctypes::_call_raw error: specified %i arguments but supplied %i", 
356              __LINE__, args_in_sig, num_args );
357     } else {
358        debug_warn( "#[Ctypes.xs: %i ] Sig validated, %i args supplied", 
359              __LINE__, num_args );
360     }
361
362     rtype = get_ffi_type( sig[1] );
363     debug_warn( "#[Ctypes.xs: %i ] Return type found: %c", __LINE__,  sig[1] );
364     rsize = FFI_SIZEOF_ARG;
365     if (sig[1] == 'd') rsize = sizeof(double);
366     if (sig[1] == 'D') rsize = sizeof(long double);
367     rvalue = (char*)malloc(rsize);
368
369     if( num_args > 0 ) {
370       int i;
371       char type;
372       debug_warn( "#[Ctypes.xs: %i ] Getting types & values of args...", __LINE__ );
373       for (i = 0; i < num_args; ++i){
374         type = sig[i+2];
375         debug_warn( "#  type %i: %c", i+1, type);
376         if (type == 0)
377           croak("Ctypes::_call_raw error: too many args (%d expected)", i - 2); /* should never happen here */
378
379         argtypes[i] = get_ffi_type(type);
380         /* Could pop ST(0) & ST(1) (func pointer & sig) off beforehand to make this neater? */
381         SV* thisSV = ST(i+2);
382         if(SvROK(thisSV)) {
383           thisSV = SvRV(ST(i+2));
384         }
385         switch(type)
386         {
387         case 'c':
388           Newxc(argvalues[i], 1, char, char);
389           *(char*)argvalues[i] = SvIV(thisSV);
390           break;
391         case 'C':
392           Newxc(argvalues[i], 1, unsigned char, unsigned char);
393           *(unsigned char*)argvalues[i] = SvIV(thisSV);
394           break;
395         case 's':
396           Newxc(argvalues[i], 1, short, short);
397           *(short*)argvalues[i] = SvIV(thisSV);
398           break;
399         case 'S':
400           Newxc(argvalues[i], 1, unsigned short, unsigned short);
401           *(unsigned short*)argvalues[i] = SvIV(thisSV);
402           break;
403         case 'i':
404           Newxc(argvalues[i], 1, int, int);
405           *(int*)argvalues[i] = SvIV(thisSV);
406           break;
407         case 'I':
408           Newxc(argvalues[i], 1, unsigned int, unsigned int);
409           *(int*)argvalues[i] = SvIV(thisSV);
410           break;
411         case 'l':
412           Newxc(argvalues[i], 1, long, long);
413           *(long*)argvalues[i] = SvIV(thisSV);
414           break;
415         case 'L':
416           Newxc(argvalues[i], 1, unsigned long, unsigned long);
417           *(unsigned long*)argvalues[i] = SvIV(thisSV);
418          break;
419         case 'f':
420           Newxc(argvalues[i], 1, float, float);
421           *(float*)argvalues[i] = SvNV(thisSV);
422           break;
423         case 'd':
424           Newxc(argvalues[i], 1, double, double);
425           *(double*)argvalues[i]  = SvNV(thisSV);
426           break;
427         case 'D':
428           Newxc(argvalues[i], 1, long double, long double);
429           *(long double*)argvalues[i] = SvNV(thisSV);
430           break;
431         case 'p':
432           len = sv_len(thisSV);
433           Newx(argvalues[i], 1, void);
434           if(SvIOK(thisSV)) {
435             debug_warn( "#    [%i] Pointer: SvIOK: assuming 'PTR2IV' value",  __LINE__ );
436             *(intptr_t*)argvalues[i] = (intptr_t)INT2PTR(void*, SvIV(thisSV));
437           } else {
438             debug_warn( "#    [%i] Pointer: Not SvIOK: assuming 'pack' value",  __LINE__ );
439             *(intptr_t*)argvalues[i] = (intptr_t)SvPVX(thisSV);
440           }
441           break;
442         /* should never happen here */
443         default: croak( "Ctypes::_call error: Unrecognised type '%c' (line %i)",
444                          type, __LINE__ );
445         }        
446       }
447     } else {
448       debug_warn( "#[Ctypes.xs: %i ] No argtypes/values to get", __LINE__ );
449     }
450     if((status = ffi_prep_cif
451          (&cif,
452           /* x86-64 uses for 'c' UNIX64 resp. WIN64, which is f not c */
453           sig[0] == 's' ? FFI_STDCALL : FFI_DEFAULT_ABI,
454           num_args, rtype, argtypes)) != FFI_OK ) {
455       croak( "Ctypes::_call error: ffi_prep_cif error %d", status );
456     }
457
458     debug_warn( "#[%s:%i] cif OK.", __FILE__, __LINE__ );
459
460     debug_warn( "#[%s:%i] Calling ffi_call...", __FILE__, __LINE__ );
461     ffi_call(&cif, FFI_FN(addr), rvalue, argvalues);
462     debug_warn( "#ffi_call returned normally with rvalue at 0x%x", (unsigned int)(intptr_t)rvalue );
463     debug_warn( "#[%s:%i] Pushing retvals to Perl stack...", __FILE__, __LINE__ );
464     switch (sig[1])
465     {
466       case 'v': break;
467       case 'c': 
468       case 'C': XPUSHs(sv_2mortal(newSViv(*(int*)rvalue)));   break;
469       case 's': 
470       case 'S': XPUSHs(sv_2mortal(newSVpv((char *)rvalue, 0)));   break;
471       case 'i': XPUSHs(sv_2mortal(newSViv(*(int*)rvalue)));   break;
472       case 'I': XPUSHs(sv_2mortal(newSVuv(*(unsigned int*)rvalue)));   break;
473       case 'l': XPUSHs(sv_2mortal(newSViv(*(long*)rvalue)));   break;
474       case 'L': XPUSHs(sv_2mortal(newSVuv(*(unsigned long*)rvalue)));   break;
475       case 'f': XPUSHs(sv_2mortal(newSVnv(*(float*)rvalue)));    break;
476       case 'd': XPUSHs(sv_2mortal(newSVnv(*(double*)rvalue)));    break;
477       case 'D': XPUSHs(sv_2mortal(newSVnv(*(long double*)rvalue)));    break;
478       case 'p': XPUSHs(sv_2mortal(newSVpv((void*)rvalue, 0))); break;
479     }
480
481     debug_warn( "#[%s:%i] Cleaning up...", __FILE__, __LINE__ );
482     free(rvalue);
483     int i = 0;
484     for( i = 0; i < num_args; i++ ) {
485       Safefree(argvalues[i]);
486       debug_warn( "#    Successfully free'd argvalues[%i]", i );
487     }
488     debug_warn( "#[%s:%i] Leaving XS_Ctypes_call...\n\n", __FILE__, __LINE__ );
489
490
491 MODULE = Ctypes         PACKAGE = Ctypes::Function
492
493 void
494 _call(self, ...)
495     SV* self;
496   PROTOTYPE: DISABLE
497   PPCODE:
498     ffi_cif cif;
499     ffi_status status;
500     ffi_type *rtype;
501     char *rvalue, rtypechar;
502     STRLEN len;
503     unsigned int num_argtypes, rsize;
504     unsigned int num_args = items - 1;
505     ffi_type *argtypes[num_args];
506     void *argvalues[num_args];
507     SV *self_argtypesRV, *rtypeSV;
508     AV *self_argtypes;
509     STRLEN tc_len = 1;
510
511     debug_warn( "\n#[%s:%i] XS_Ctypes_Function__call( %i args )",
512                 __FILE__, __LINE__, num_args );
513     debug_warn( "#Module compiled with -DCTYPES_DEBUG for detailed output from XS" );
514 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
515     if( num_args < 0 ) {
516       croak( "Ctypes::_call error: Not enough arguments" );
517     }
518 #endif
519
520     if( !(Ct_Obj_IsDeriv(self,"Ctypes::Function"))) 
521       croak("Ctypes::_call: $self must be a Ctypes::Function or derivative");
522
523     rtypeSV = Ct_HVObj_GET_ATTR_KEY(self, "restype");
524     if( Ct_Obj_IsDeriv(rtypeSV,"Ctypes::Type") ) {
525       rtypechar =
526         (char)*SvPV_nolen(Ct_HVObj_GET_ATTR_KEY(rtypeSV,"_typecode"));
527       rtype = get_ffi_type( rtypechar );
528     } else {
529       rtypechar = (char)*SvPV_nolen(rtypeSV);
530       rtype = get_ffi_type( rtypechar );
531     }
532     debug_warn( "#[Ctypes.xs:%i] Return type found: %c", __LINE__,  rtypechar );
533     rsize = FFI_SIZEOF_ARG;
534     if (rtypechar == 'd') rsize = sizeof(double);
535     if (rtypechar == 'D') rsize = sizeof(long double);
536     rvalue = (char*)malloc(rsize);
537  
538     if( num_args > 0 ) {
539       debug_warn( "#[%s:%i] Getting types & values of args...",
540         __FILE__, __LINE__ );
541
542       int i, err;
543       char type_expected;
544       char type_got;
545       char type;
546
547       /* get $self->argtypes and make sure they make sense */
548       self_argtypesRV = Ct_HVObj_GET_ATTR_KEY(self, "argtypes");
549       if( self_argtypesRV == NULL ) {
550         self_argtypes == NULL;
551       } else {
552         if( !( SvROK(self_argtypesRV)
553                && SvTYPE(SvRV(self_argtypesRV)) == SVt_PVAV) )
554           croak("Ctypes::_call error: argtypes must be array reference");
555         else
556           self_argtypes = (AV*)SvRV(self_argtypesRV);
557         if( av_len(self_argtypes) == -1 ) {
558           /* could this equally be SvREFCNT_dec(self_argtypes)? */ 
559           SvREFCNT_dec(self_argtypesRV);
560           self_argtypes == NULL;
561         }
562       }
563       debug_warn("#    num_args is %i", num_args);
564       for (i = 0; i < num_args; ++i) {
565         debug_warn("#    i is %i", i);
566         SV *this_arg = ST(i+1);
567         SV *this_argtype, **fetched_argtype;
568         if( self_argtypes ) {
569           fetched_argtype = av_fetch(self_argtypes, i, 0);
570           if( fetched_argtype != NULL ) {
571             this_argtype = *fetched_argtype;
572             type_expected = Ct_Obj_IsDeriv(this_argtype, "Ctypes::Type")
573               ? (char)*SvPV(Ct_HVObj_GET_ATTR_KEY(this_argtype,"_typecode"),tc_len)
574               : (char)*SvPV(this_argtype,tc_len);
575           } else {
576   croak("[%s:%i] Function::_call error: Can't grok argtype at position %i",
577                   __FILE__, __LINE__, i);
578           }
579         } else {
580           this_argtype = NULL;
581           type_expected = '\0';
582         }
583
584         /* err not used yet, ConvArg croaks a lot */
585         debug_warn("#    calling ConvArg...");
586         err = ConvArg( this_arg,
587                  type_expected,
588                  argtypes,
589                  argvalues,
590                  i);
591       }
592
593       if( av_len(self_argtypes) > -1 ) /* if not, has been dec'd already */
594         SvREFCNT_dec(self_argtypesRV);
595
596     } else {
597       debug_warn( "#[Ctypes.xs: %i ] No argtypes/values to get", __LINE__ );
598     }
599
600     char abi =  *SvPV((Ct_HVObj_GET_ATTR_KEY(self,"abi")),tc_len);
601     void* addr = INT2PTR(void*,(int)SvIV(Ct_HVObj_GET_ATTR_KEY(self,"func")));
602
603     if((status = ffi_prep_cif
604          (&cif,
605           /* x86-64 uses for 'c' UNIX64 resp. WIN64, which is f not c */
606            abi == 's' ? FFI_STDCALL : FFI_DEFAULT_ABI,
607           num_args, rtype, argtypes)) != FFI_OK ) {
608       croak( "Ctypes::_call error: ffi_prep_cif error %d", status );
609     }
610
611     debug_warn( "#[%s:%i] cif OK.", __FILE__, __LINE__ );
612
613     debug_warn( "#[%s:%i] Calling ffi_call...", __FILE__, __LINE__ );
614     ffi_call(&cif, FFI_FN(addr), rvalue, argvalues);
615     debug_warn( "#    ffi_call returned!");
616
617     debug_warn( "#[%s:%i] Pushing retvals to Perl stack...", __FILE__, __LINE__ );
618     switch (rtypechar)
619     {
620       case 'v': break;
621       case 'c': 
622       case 'C': XPUSHs(sv_2mortal(newSViv(*(int*)rvalue)));   break;
623       case 's': 
624       case 'S': XPUSHs(sv_2mortal(newSVpv((char *)rvalue, 0)));   break;
625       case 'i': XPUSHs(sv_2mortal(newSViv(*(int*)rvalue)));   break;
626       case 'I': XPUSHs(sv_2mortal(newSVuv(*(unsigned int*)rvalue)));   break;
627       case 'l': XPUSHs(sv_2mortal(newSViv(*(long*)rvalue)));   break;
628       case 'L': XPUSHs(sv_2mortal(newSVuv(*(unsigned long*)rvalue)));   break;
629       case 'f': XPUSHs(sv_2mortal(newSVnv(*(float*)rvalue)));    break;
630       case 'd': XPUSHs(sv_2mortal(newSVnv(*(double*)rvalue)));    break;
631       case 'D': XPUSHs(sv_2mortal(newSVnv(*(long double*)rvalue)));    break;
632       case 'p': XPUSHs(sv_2mortal(newSVpv((void*)rvalue, 0))); break;
633     }
634
635     debug_warn( "#[%s:%i] Cleaning up...", __FILE__, __LINE__ );
636     free(rvalue);
637     int i = 0;
638     for( i = 0; i < num_args; i++ ) {
639       Safefree(argvalues[i]);
640       debug_warn( "#    Successfully free'd argvalues[%i]", i );
641     }
642     debug_warn( "#[%s:%i] Leaving XS_Ctypes_call...\n\n", __FILE__, __LINE__ );
643
644
645 MODULE = Ctypes         PACKAGE = Ctypes
646
647 int 
648 sizeof(type)
649     char type;
650 CODE:
651   switch (type) {
652   case 'v': RETVAL = 0;           break;
653   case 'c':
654   case 'C': RETVAL = 1;           break;
655   case 's':
656   case 'S': RETVAL = 2;           break;
657   case 'i': 
658   case 'I': RETVAL = sizeof(int); break;
659   case 'l': 
660   case 'L': RETVAL = sizeof(long);  break;
661   case 'f': RETVAL = sizeof(float); break;
662   case 'd': RETVAL = sizeof(double);     break;
663   case 'D': RETVAL = sizeof(long double);break;
664   case 'p': RETVAL = sizeof(void*);      break;
665   default: croak( "Unrecognised type: %c", type );
666   }
667 OUTPUT:
668   RETVAL
669
670 int
671 _valid_for_type(arg_sv,type)
672   SV* arg_sv;
673   char type;
674 CODE:
675   void* arg_p;
676   NV arg_nv;
677   short i;
678   RETVAL = 0;
679   debug_warn("#[%s:%i] Entered _valid_for_type with type %c",
680     __FILE__, __LINE__, type);
681   if( !SvOK(arg_sv) || !type ) { XSRETURN_UNDEF; }
682   switch (type) {
683     case 'v': break;
684     case 'c':
685     case 'C':
686       debug_warn("#    A char type...");
687     /* We want the real value, not implicit conversion */
688       if( SvIOK(arg_sv) || SvNOK(arg_sv) ) {
689         arg_nv = SvNV(arg_sv);
690         debug_warn("#[%i]    Numeric value of arg was %g", __LINE__, arg_nv);
691         if( arg_nv < CHAR_MIN || arg_nv > CHAR_MAX ) {
692           /* no wrap-around: higher bits discarded for char */
693           debug_warn("#    ... out of range, needs cast");
694           RETVAL = 0; break;
695         }
696       } else if( SvPOK(arg_sv) ) {
697         debug_warn("#    arg was SvPOK, will be converted to int in cast");
698         RETVAL = 0; break;
699       } else {
700         croak("[%s:%i] Ctypes::_cast error: arg for type %c not IOK, NOK or POK",
701           __FILE__, __LINE__, type);
702       }
703       RETVAL = 1; break;
704     case 's':
705       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
706       arg_nv = SvNV(arg_sv);
707       if( arg_nv < PERL_SHORT_MIN || arg_nv > PERL_SHORT_MAX ) {
708         RETVAL = -1; break;
709       }
710       RETVAL = 1; break;
711     case 'S':
712       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
713       arg_nv = SvNV(arg_sv);
714       if( arg_nv < PERL_USHORT_MIN || arg_nv > PERL_USHORT_MAX ) {
715         RETVAL = -1; break;
716       }
717       RETVAL = 1; break;
718     case 'i':
719       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
720       arg_nv = SvNV(arg_sv);
721       if( arg_nv < PERL_INT_MIN || arg_nv > PERL_INT_MAX ) {
722         RETVAL = -1; break;
723       }
724       RETVAL = 1; break;
725     case 'I':
726       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
727       arg_nv = SvNV(arg_sv);
728       if( arg_nv < PERL_UINT_MIN || arg_nv > PERL_UINT_MAX ) {
729         RETVAL = -1; break;
730       }
731       RETVAL = 1; break;
732     case 'l':
733     /* ??? Are Longs always guaranteed to be IV rather than NV? */
734       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
735       arg_nv = SvNV(arg_sv);
736       if( arg_nv < PERL_LONG_MIN || arg_nv > PERL_LONG_MAX ) {
737         RETVAL = -1; break;
738       }
739       RETVAL = 1; break;
740     case 'L':
741       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
742       arg_nv = SvNV(arg_sv);
743       if( arg_nv < PERL_ULONG_MIN || arg_nv > PERL_ULONG_MAX ) {
744         RETVAL = -1; break;
745       }
746       RETVAL = 1; break;
747     case 'f':
748       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
749     /* ??? Is NV, usually double, alright to use here?
750        Also, any Perl vars to use instead of stdlib ones? */
751       arg_nv = SvNV(arg_sv);
752       if( ( FLT_MIN - arg_nv) > FLT_EPSILON || (arg_nv - FLT_MAX) > FLT_EPSILON ) {
753         RETVAL = -1; break;
754       }
755       RETVAL = 1; break;
756     case 'd':
757       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
758       arg_nv = SvNV(arg_sv);
759       if( (DBL_MIN - arg_nv) > DBL_EPSILON || (arg_nv - DBL_MAX) > DBL_EPSILON ) {
760         RETVAL = -1; break;  /* XXX Wtf... what's going wrong here??? */
761       }
762       RETVAL = 1; break;
763 #ifdef HAS_LONG_DOUBLE
764     case 'D':
765       if( !SvNOKp(arg_sv) && !SvIOK(arg_sv) ) break;
766       arg_nv = SvNV(arg_sv);
767       if( (LDBL_MIN - arg_nv) > LDBL_EPSILON || (arg_nv - LDBL_MAX) > LDBL_EPSILON ) {
768         RETVAL = -1; break;
769       }
770       RETVAL = 1; break;
771 #endif
772     case 'p':
773     /* Pointers can be just about anything
774        ??? Could this be improved? */
775       if( !SvPOK(arg_sv) && !SvNOK(arg_sv) && !SvIOK(arg_sv) ) {
776         debug_warn("#[%s:%i] _valid_for_type: arg_sv wasn't Anything. What did you pass??",
777                    __FILE__, __LINE__ );
778         RETVAL = 0; break;
779       }
780       RETVAL = 1; break;
781     default: croak( "Invalid type: %c", type );
782   }
783 OUTPUT:
784   RETVAL
785
786 SV*
787 _cast(arg_sv,type)
788   SV* arg_sv;
789   char type;
790 CODE:
791   debug_warn("#[%s:%i] _cast: got type %c", __FILE__, __LINE__, type);
792   void *retval = NULL;
793 #ifdef HAS_LONG_DOUBLE
794   Newxc(retval, 1, long double, long double);
795 #else
796   Newxc(retval, 1, double, double);
797 #endif
798   if(retval == NULL) croak("Ctypes::_cast: Out of memory!");
799   STRLEN len = 1;
800   STRLEN utf8retlen = 0;
801   NV arg_nv;
802   short set = 0;
803   char achar;
804   RETVAL = &PL_sv_undef;
805   switch (type) {
806     case 'c':
807       debug_warn("Case 'c'");
808       if(SvIOK(arg_sv)) {
809         debug_warn("\targ was SvIOK");
810         ((signed char*)retval)[0] = (signed char)SvIV(arg_sv);
811         set = 1;
812       } else if(SvNOK(arg_sv)) {
813         debug_warn("\targ was SvNOK");
814         ((signed char*)retval)[0] = (signed char)SvNV(arg_sv);
815         set = 1;
816       } else if(SvPOK(arg_sv)) {
817         debug_warn("\targ was SvPOK");
818         ((signed char*)retval)[0] = (signed char)*SvPV_nolen(arg_sv);
819         set = 1;
820       }
821       if(set == 1) {
822         debug_warn("\tretval is %c", *(signed char*)retval);
823         RETVAL = newSViv((int)(((signed char*)retval)[0]));
824       }
825       break;
826     case 'C':
827       debug_warn("#[%i] _cast 'C'", __LINE__);
828       if( SvIOK(arg_sv) || SvNOK(arg_sv) ) {
829         arg_nv = SvNV(arg_sv);
830         debug_warn("#[%i]    Numeric value of arg was %g", __LINE__, arg_nv);
831         if( arg_nv > CHAR_MAX ) arg_nv = CHAR_MAX;
832         if( arg_nv < CHAR_MIN ) arg_nv = CHAR_MIN;
833         ((unsigned char*)retval)[0] = (char)arg_nv;
834         set = 1;
835         debug_warn("#[%i]    retval is now %i as integer and %c as char",
836                    __LINE__, (int)(((unsigned char*)retval)[0]),
837                   (char)(((unsigned char*)retval)[0]) );
838       } else if(SvPOK(arg_sv)) {
839         debug_warn("#[%i]    arg was SvPOK", __LINE__);
840         ((unsigned char*)retval)[0] = (SvPV(arg_sv, len))[0];
841         set = 1;
842         debug_warn("#[%i]    retval is now %i as integer and %c as char",
843                    __LINE__, (int)(((unsigned char*)retval)[0]),
844                   (char)(((unsigned char*)retval)[0]) );
845       }
846       /* Following check not appropriate as input '0' would be char NULL
847       if(((unsigned char*)retval)[0]) {   */
848       if(set == 1) {
849         RETVAL = newSViv((int)(((unsigned char*)retval)[0]));
850       }
851       break;
852     case 's':
853       if(SvIOK(arg_sv)) {
854         *(short int*) retval = (short int)SvIV(arg_sv);
855       } else if(SvNOK(arg_sv)) {
856         *(short int*) retval = (short int)SvNV(arg_sv);
857       } else if(SvPOK(arg_sv)) {
858         *(short int*) retval = (short int)*SvPV_nolen(arg_sv);
859       }
860       if(*(short int*)retval) {
861         RETVAL = newSViv(*(short int*)retval);
862       }
863       break;
864     case 'S':
865       if(SvIOK(arg_sv)) {
866         *(unsigned short*) retval = (unsigned short)SvIV(arg_sv);
867       } else if(SvNOK(arg_sv)) {
868         *(unsigned short*) retval = (unsigned short)SvNV(arg_sv);
869       } else if(SvPOK(arg_sv)) {
870         *(unsigned short*) retval = (unsigned short)*SvPV_nolen(arg_sv);
871       }
872       if(*(unsigned short*)retval) {
873         RETVAL = newSViv(*(unsigned short*)retval);
874       }
875       break;
876     case 'i':
877       debug_warn("Case 'i'");
878       if(SvIOK(arg_sv)) {
879         debug_warn("\targ was SvIOK");
880         *(int*) retval = (int)SvIV(arg_sv);
881       } else if(SvNOK(arg_sv)) {
882         debug_warn("\targ was SvNOK");
883         *(int*) retval = (int)SvNV(arg_sv);
884       } else if(SvPOK(arg_sv)) {
885         debug_warn("\targ was SvPOK");
886         if(SvUTF8(arg_sv)) {
887           debug_warn("\tThis is utf8!");
888           *(int*)retval =
889             (int)utf8_to_uvchr((SvPVutf8_nolen(arg_sv)), &utf8retlen);
890         }
891         else {
892           debug_warn("\tThis is Not utf8");
893           *(int*)retval = (int)*(SvPV_nolen(arg_sv));
894         }
895       }
896       if(*(int*)retval) {
897         debug_warn("\tretval is %i", *(int*)retval);
898         RETVAL = newSViv(*(int*)retval);
899       }
900       break;
901     case 'I':
902       if(SvIOK(arg_sv)) {
903         *(unsigned int*) retval = (unsigned int)SvIV(arg_sv);
904       } else if(SvNOK(arg_sv)) {
905         *(unsigned int*) retval = (unsigned int)SvNV(arg_sv);
906       } else if(SvPOK(arg_sv)) {
907         *(unsigned int*) retval = (unsigned int)*SvPV_nolen(arg_sv);
908       }
909       if(*(unsigned int*)retval) {
910         RETVAL = newSViv(*(unsigned int*)retval);
911       }
912       break;
913     case 'l':
914       if(SvIOK(arg_sv)) {
915         *(long*) retval = (long)SvIV(arg_sv);
916       } else if(SvNOK(arg_sv)) {
917         *(long*) retval = (long)SvNV(arg_sv);
918       } else if(SvPOK(arg_sv)) {
919         *(long*) retval = (long)*SvPV_nolen(arg_sv);
920       }
921       if(*(long*)retval) {
922         if(LONGSIZE <= IVSIZE)
923           RETVAL = newSViv(*(long*)retval);
924         else
925           RETVAL = newSVnv(*(long*)retval);
926       }
927       break;
928     case 'L':
929       if(SvIOK(arg_sv)) {
930         *(unsigned long*) retval = (unsigned long)SvIV(arg_sv);
931       } else if(SvNOK(arg_sv)) {
932         *(unsigned long*) retval = (unsigned long)SvNV(arg_sv);
933       } else if(SvPOK(arg_sv)) {
934         *(unsigned long*) retval = (unsigned long)*SvPV_nolen(arg_sv);
935       }
936       if(*(unsigned long*)retval) {
937         if(LONGSIZE <= IVSIZE)
938           RETVAL = newSViv(*(long*)retval);
939         else
940           RETVAL = newSVnv(*(long*)retval);
941       }
942       break;
943     case 'f':
944       if(SvIOK(arg_sv)) {
945         *(float*) retval = (float)SvIV(arg_sv);
946       } else if(SvNOK(arg_sv)) {
947         *(float*) retval = (float)SvNV(arg_sv);
948       } else if(SvPOK(arg_sv)) {
949         *(float*) retval = (float)*SvPV_nolen(arg_sv);
950       }
951       if(*(float*)retval) {
952         RETVAL = newSVnv(*(float*)retval);
953       }
954       break;
955     case 'd':
956       if(SvIOK(arg_sv)) {
957         *(double*) retval = (double)SvIV(arg_sv);
958       } else if(SvNOK(arg_sv)) {
959         *(double*) retval = (double)SvNV(arg_sv);
960       } else if(SvPOK(arg_sv)) {
961         *(double*) retval = (double)*SvPV_nolen(arg_sv);
962       }
963       if(*(double*)retval) {
964         RETVAL = newSVnv(*(double*)retval);
965       }
966       break;
967 #ifdef HAS_LONG_DOUBLE
968     case 'D':
969       if(SvIOK(arg_sv)) {
970         *(long double*) retval = (long double)SvIV(arg_sv);
971       } else if(SvNOK(arg_sv)) {
972         *(long double*) retval = (long double)SvNV(arg_sv);
973       } else if(SvPOK(arg_sv)) {
974         *(long double*) retval = (long double)*SvPV_nolen(arg_sv);
975       }
976       if(*(long double*)retval) {
977         RETVAL = newSVnv(*(long double*)retval);
978       }
979       break;
980 #endif
981     case 'p':
982       if(SvIOK(arg_sv)) {
983       debug_warn("#[%s:%i] _cast: Pointer SvIOK, assuming 'PTR2IV' value",
984         __FILE__, __LINE__ );
985         *(intptr_t*)retval = (intptr_t)INT2PTR(void*, SvIV(arg_sv));
986       } else {
987       debug_warn("#[%s:%i] _case: Pointer not SvIOK, assuming 'pack' value",
988         __FILE__,  __LINE__ );
989         *(intptr_t*)retval = (intptr_t)SvPVX(arg_sv);
990       }
991       if(retval) {
992           RETVAL = newSViv(PTR2IV(*(intptr_t*)retval));
993       }
994       break;
995     default: croak( "Unimplemented / Invalid type: %c", type );
996   }
997   Safefree(retval);
998 OUTPUT:
999   RETVAL
1000
1001 MODULE=Ctypes   PACKAGE=Ctypes::Callback
1002
1003 void
1004 _make_callback( coderef, sig, ... )
1005     STRLEN siglen = 0;
1006     SV* coderef = newSVsv(ST(0));
1007     char* sig = (char*)SvPV(ST(1), siglen);
1008   PPCODE:
1009     /* It should be remembered that unlike Ctypes::_call above,
1010        sig here won't include an abi (since it refers to a Perl
1011        function), so offsets for arg types will always be +1, not +2 */
1012     ffi_status status = FFI_BAD_TYPEDEF;
1013     ffi_type *rtype;
1014     char *rvalue;
1015     unsigned int args_in_sig, rsize;
1016     unsigned int num_args = siglen - 1;
1017     ffi_type** argtypes;
1018     cb_data_t* cb_data;
1019     void* code;
1020     ffi_cif* cb_cif;
1021     ffi_closure* closure;
1022
1023     debug_warn( "\n#[%s:%i] Entered _make_callback", __FILE__, __LINE__ );
1024     
1025     debug_warn( "#[%s:%i] Allocating memory for  closure...", __FILE__, __LINE__ );
1026     closure = ffi_closure_alloc( sizeof(ffi_closure), &code );
1027
1028     Newx( cb_data, 1, cb_data_t );
1029     Newx(cb_data->cif, 1, ffi_cif);
1030     Newx(argtypes, num_args, ffi_type*);
1031
1032     debug_warn( "#[%s:%i] Setting rtype '%c'", __FILE__, __LINE__, sig[0] );
1033     rtype = get_ffi_type( sig[0] );
1034
1035     if( num_args > 0 ) {
1036       int i;
1037       for( i = 0; i < num_args; i++ ) {
1038         argtypes[i] = get_ffi_type(sig[i+1]); 
1039         debug_warn( "#    Got argtype '%c'", sig[i+1] );
1040       }
1041     }
1042
1043     debug_warn( "#[%s:%i] Prep'ing cif for _perl_cb_call...", __FILE__, __LINE__ ); 
1044     if((status = ffi_prep_cif
1045         (cb_data->cif,
1046          /* Might Perl XS libs use stdcall on win32? How to check? */
1047          FFI_DEFAULT_ABI,
1048          num_args, rtype, argtypes)) != FFI_OK ) {
1049        croak( "Ctypes::_call error: ffi_prep_cif error %d", status );
1050      }
1051
1052     debug_warn( "#[%s:%i] Prep'ing closure...", __FILE__, __LINE__ ); 
1053     if((status = ffi_prep_closure_loc
1054         ( closure, cb_data->cif, &_perl_cb_call, cb_data, code )) != FFI_OK ) {
1055         croak( "Ctypes::Callback::new error: ffi_prep_closure_loc error %d",
1056             status );
1057         }
1058
1059     cb_data->sig = sig;
1060     cb_data->coderef = coderef;
1061     cb_data->closure = closure;
1062
1063     unsigned int len = sizeof(intptr_t);
1064     XPUSHs(sv_2mortal(newSViv(PTR2IV(code))));    /* pointer type void */
1065     XPUSHs(sv_2mortal(newSViv(PTR2IV(cb_data)))); 
1066
1067 void
1068 DESTROY(self)
1069     SV* self;
1070 PREINIT:
1071     cb_data_t* data;
1072     HV* selfhash;
1073     SV** svValue;
1074     int intFromPerl;
1075 PPCODE:
1076     if( !sv_isa(self, "Ctypes::Callback") ) {
1077       croak( "Callback::DESTROY called on non-Callback object" );
1078     }
1079
1080     svValue = hv_fetch((HV*)SvRV(self), "_cb_data", 8, 0 );
1081     if(!svValue) { croak("No _cb_data ptr from Perl"); }
1082     intFromPerl = SvIV(*svValue);
1083     data = INT2PTR(cb_data_t*, intFromPerl);
1084
1085     ffi_closure_free(data->closure);
1086     Safefree(data->cif->arg_types);
1087     Safefree(data->cif);
1088     Safefree(data);