/* -*-C-*- ------------------------------------------------------------- | Module: wine.xs | | -------------------------------------------------------------------- | | Purpose: Perl gateway to wine API calls | | | ----------------------------------------------------------------------*/ #include "config.h" #include #include #include "windef.h" #include #include #include #undef WORD #include "winbase.h" /* API return type constants */ enum ret_type { RET_VOID = 0, RET_INT = 1, RET_WORD = 2, RET_PTR = 3, RET_STR = 4 }; /* max arguments for a function call */ #define MAX_ARGS 16 extern unsigned long perl_call_wine ( FARPROC function, int n_args, unsigned long *args, unsigned int *last_error, int debug ); /* Thunk type definitions */ #ifdef __i386__ #pragma pack(1) struct thunk { BYTE pushl; BYTE movl[2]; BYTE leal_args[3]; BYTE pushl_args; BYTE pushl_addr; BYTE *args_ptr; BYTE pushl_nb_args; BYTE nb_args; BYTE pushl_ref; SV *code_ref; BYTE call; void *func; BYTE leave; BYTE ret; short arg_size; BYTE arg_types[MAX_ARGS]; }; #pragma pack(4) #else #error You must implement the callback thunk for your CPU #endif /*-------------------------------------------------------------- | This contains most of the machine instructions necessary to | implement the thunk. All the thunk does is turn around and | call function callback_bridge(), which is defined in | winetest.c. | | The data from this static thunk can just be copied directly | into the thunk allocated dynamically below. That fills in | most of it, but a couple values need to be filled in after | the allocation, at run time: | | 1) The pointer to the thunk's data area, which we | don't know yet, because we haven't allocated it | yet ... | | 2) The address of the function to call. We know the | address of the function [callback_bridge()], but | the value filled into the thunk is an address | relative to the thunk itself, so we can't fill it | in until we've allocated the actual thunk. --------------------------------------------------------------*/ static const struct thunk thunk_template = { /* pushl %ebp */ 0x55, /* movl %esp,%ebp */ { 0x89, 0xe5 }, /* leal 8(%ebp),%edx */ { 0x8d, 0x55, 0x08 }, /* pushl %edx */ 0x52, /* pushl (data addr) */ 0x68, NULL, /* pushl (nb_args) */ 0x6a, 0, /* pushl (code ref) */ 0x68, NULL, /* call (func) */ 0xe8, NULL, /* leave */ 0xc9, /* ret $arg_size */ 0xc2, 0, /* arg_types */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 } }; /*---------------------------------------------------------------------- | Function: convert_value | | -------------------------------------------------------------------- | | Purpose: Convert a C value to a Perl value | | | | Parameters: type -- constant specifying type of value | | val -- value to convert | | | | Returns: Perl SV * | ----------------------------------------------------------------------*/ static SV *convert_value( enum ret_type type, unsigned long val ) { switch (type) { case RET_VOID: return &PL_sv_undef; case RET_INT: return sv_2mortal( newSViv ((int) val )); case RET_WORD: return sv_2mortal( newSViv ((int) val & 0xffff )); case RET_PTR: return sv_2mortal( newSViv ((int) val )); case RET_STR: return sv_2mortal( newSVpv ((char *) val, 0 )); } croak ("Bad return type %d", type); return &PL_sv_undef; } /*---------------------------------------------------------------------- | Function: callback_bridge | | -------------------------------------------------------------------- | | Purpose: Central pass-through point for Wine API callbacks | | | | Wine API callback thunks are set up so that they call this | | function, which turns around and calls the user's declared | | Perl callback sub. | | | | Parameters: data -- pointer to thunk data area | | args -- array of args passed from Wine API to callback | | | | Returns: Whatever the Perl sub returns | ----------------------------------------------------------------------*/ static int callback_bridge( SV *callback_ref, int nb_args, BYTE arg_types[], unsigned long args[] ) { /* Locals */ int i, n; SV *sv; int r = 0; /* Perl/C interface voodoo */ dSP; ENTER; SAVETMPS; PUSHMARK(sp); /* Push args on stack, according to type */ for (i = 0; i < nb_args; i++) { sv = convert_value (arg_types[i], args[i]); PUSHs (sv); } PUTBACK; /* Call Perl sub */ n = perl_call_sv (callback_ref, G_SCALAR); /* Nab return value */ SPAGAIN; if (n == 1) { r = POPi; } PUTBACK; FREETMPS; LEAVE; /* [todo] Pass through Perl sub return value */ return (r); } /*---------------------------------------------------------------------- | XS module | | | | | ----------------------------------------------------------------------*/ MODULE = wine PACKAGE = wine # -------------------------------------------------------------------- # Function: call_wine_API # -------------------------------------------------------------------- # Purpose: Call perl_call_wine(), which calls a wine API function # # Parameters: function -- API function to call # ret_type -- return type # debug -- debug flag # ... -- args to pass to API function # # Returns: list containing 2 elements: the last error code and the # value returned by the API function # -------------------------------------------------------------------- void call_wine_API(function, ret_type, debug, ...) unsigned long function; int ret_type; int debug; PROTOTYPE: $$$@ PPCODE: /*-------------------------------------------------------------- | Begin call_wine_API --------------------------------------------------------------*/ /* Local types */ struct arg { int ival; void *pval; }; /* Locals */ int n_fixed = 3; int n_args = (items - n_fixed); struct arg args[MAX_ARGS+1]; unsigned long f_args[MAX_ARGS+1]; unsigned int i, n; unsigned int last_error = 0xdeadbeef; char *p; SV *sv; unsigned long r; if (n_args > MAX_ARGS) croak("Too many arguments"); /*-------------------------------------------------------------- | Prepare function args --------------------------------------------------------------*/ if (debug > 1) { fprintf( stderr, " [wine.xs/call_wine_API()]\n"); } for (i = 0; (i < n_args); i++) { sv = ST (n_fixed + i); args[i].pval = NULL; if (! SvOK (sv)) continue; /*-------------------------------------------------------------- | Ref --------------------------------------------------------------*/ if (SvROK (sv)) { sv = SvRV (sv); /*-------------------------------------------------------------- | Integer ref -- pass address of value --------------------------------------------------------------*/ if (SvIOK (sv)) { args[i].ival = SvIV (sv); f_args[i] = (unsigned long) &(args[i].ival); if (debug > 1) { fprintf( stderr, " [RV->IV] 0x%lx\n", f_args[i]); } } /*-------------------------------------------------------------- | Number ref -- convert and pass address of value --------------------------------------------------------------*/ else if (SvNOK (sv)) { args[i].ival = (unsigned long) SvNV (sv); f_args[i] = (unsigned long) &(args[i].ival); if (debug > 1) { fprintf( stderr, " [RV->NV] 0x%lx\n", f_args[i]); } } /*-------------------------------------------------------------- | String ref -- pass pointer --------------------------------------------------------------*/ else if (SvPOK (sv)) { f_args[i] = (unsigned long) ((char *) SvPV (sv, PL_na)); if (debug > 1) { fprintf( stderr, " [RV->PV] 0x%lx\n", f_args[i]); } } } /*-------------------------------------------------------------- | Scalar --------------------------------------------------------------*/ else { /*-------------------------------------------------------------- | Integer -- pass value --------------------------------------------------------------*/ if (SvIOK (sv)) { f_args[i] = (unsigned long) SvIV (sv); if (debug > 1) { fprintf( stderr, " [IV] %ld (0x%lx)\n", f_args[i], f_args[i]); } } /*-------------------------------------------------------------- | Number -- convert and pass value --------------------------------------------------------------*/ else if (SvNOK (sv)) { f_args[i] = (unsigned long) SvNV (sv); if (debug > 1) { fprintf( stderr, " [NV] %ld (0x%lx)\n", f_args[i], f_args[i]); } } /*-------------------------------------------------------------- | String -- pass pointer to copy --------------------------------------------------------------*/ else if (SvPOK (sv)) { p = SvPV (sv, n); if ((args[i].pval = malloc( n+2 ))) { memcpy (args[i].pval, p, n); ((char *)(args[i].pval))[n] = 0; /* add final NULL */ ((char *)(args[i].pval))[n+1] = 0; /* and another one for Unicode too */ f_args[i] = (unsigned long) args[i].pval; if (debug > 1) { fprintf( stderr, " [PV] 0x%lx\n", f_args[i]); } } } } } /* end for */ /*-------------------------------------------------------------- | Here we go --------------------------------------------------------------*/ r = perl_call_wine( (FARPROC)function, n_args, f_args, &last_error, debug ); /*-------------------------------------------------------------- | Handle modified parameter values | | There are four possibilities for parameter values: | | 1) integer value | 2) string value | 3) ref to integer value | 4) ref to string value | | In cases 1 and 2, the intent is that the values won't be | modified, because they're not passed by ref. So we leave | them alone here. | | In case 4, the address of the actual string buffer has | already been passed to the wine API function, which had | opportunity to modify it if it wanted to. So again, we | don't have anything to do here. | | The case we need to handle is case 3. For integers passed | by ref, we created a local containing the initial value, | and passed its address to the wine API function, which | (potentially) modified it. Now we have to copy the | (potentially) new value back to the Perl variable passed | in, using sv_setiv(). (Which will take fewer lines of code | to do than it took lines of comment to describe ...) --------------------------------------------------------------*/ for (i = 0; (i < n_args); i++) { sv = ST (n_fixed + i); if (! SvOK (sv)) continue; if (SvROK (sv) && (sv = SvRV (sv)) && SvIOK (sv)) { sv_setiv (sv, args[i].ival); } } /*-------------------------------------------------------------- | Put appropriate return value on the stack for Perl to pick | up --------------------------------------------------------------*/ EXTEND(SP,2); if (last_error != 0xdeadbeef) PUSHs(sv_2mortal(newSViv(last_error))); else PUSHs( &PL_sv_undef ); PUSHs (convert_value (ret_type, r)); /*-------------------------------------------------------------- | Free up allocated memory --------------------------------------------------------------*/ for (i = 0; (i < n_args); i++) { if (args[i].pval) free(args[i].pval); } # -------------------------------------------------------------------- # Function: load_library # -------------------------------------------------------------------- # Purpose: Load a Wine library # # Parameters: module -- module (dll) to load # # Returns: module handle # -------------------------------------------------------------------- void load_library(module) char *module; PROTOTYPE: $ PPCODE: ST(0) = newSViv( (I32)LoadLibraryA(module) ); XSRETURN(1); # -------------------------------------------------------------------- # Function: get_proc_address # -------------------------------------------------------------------- # Purpose: Retrive a function address # # Parameters: module -- module handle # -------------------------------------------------------------------- void get_proc_address(module,func) unsigned long module; char *func; PROTOTYPE: $$ PPCODE: ST(0) = newSViv( (I32)GetProcAddress( (HMODULE)module, func ) ); XSRETURN(1); # -------------------------------------------------------------------- # Function: alloc_thunk # -------------------------------------------------------------------- # Purpose: Allocate a thunk for a wine API callback # # This is used when a Wine API function is called from Perl, and # that API function takes a callback as one of its parameters. # # The Wine API function, of course, must be passed the address of # a C function as the callback. But if the API is called from Perl, # we want the user to be able to specify a Perl sub as the callback, # and have control returned there each time the callback is called. # # This function takes a code ref to a Perl sub as one of its # arguments. It then creates a unique C function (a thunk) on the # fly, which can be passed to the Wine API function as its callback. # # The thunk has its own data area (as thunks are wont to do); one # of the things stashed there is aforementioned Perl code ref. So # the sequence of events is as follows: # # 1) From Perl, user calls alloc_callback(), passing a ref # to a Perl sub to use as the callback. # # 2) alloc_callback() calls this routine. This routine # creates a thunk, and stashes the above code ref in # it. This function then returns a pointer to the thunk # to Perl. # # 3) From Perl, user calls Wine API function. As the parameter # which is supposed to be the address of the callback, the # user passes the pointer to the thunk allocated above. # # 4) The Wine API function gets called. It periodically calls # the callback, which executes the thunk. # # 5) Each time the thunk is executed, it calls callback_bridge() # (defined in winetest.c). # # 6) callback_bridge() fishes the Perl code ref out of the # thunk data area and calls the Perl callback. # # Voila. The Perl callback gets called each time the Wine API # function calls its callback. # # Parameters: [todo] Parameters ... # # Returns: Pointer to thunk # -------------------------------------------------------------------- void alloc_thunk(...) PPCODE: /* Locals */ struct thunk *thunk; int i; /* Allocate the thunk */ if (!(thunk = malloc( sizeof(*thunk) ))) croak( "Out of memory" ); (*thunk) = thunk_template; thunk->args_ptr = thunk->arg_types; thunk->nb_args = items - 1; thunk->code_ref = SvRV (ST (0)); thunk->func = (void *)((char *) callback_bridge - (char *) &thunk->leave); thunk->arg_size = thunk->nb_args * sizeof(int); /* Stash callback arg types */ for (i = 1; i < items; i++) thunk->arg_types[i - 1] = SvIV (ST (i)); /*-------------------------------------------------------------- | Push the address of the thunk on the stack for return | | [todo] We need to free up the memory allocated somehow ... --------------------------------------------------------------*/ ST (0) = newSViv ((I32) thunk); XSRETURN (1);