| /* -*-C-*- | |
| * Perl gateway to wine API calls | |
| * | |
| * Copyright 2001 John F Sturtz for Codeweavers | |
| * | |
| * This library is free software; you can redistribute it and/or | |
| * modify it under the terms of the GNU Lesser General Public | |
| * License as published by the Free Software Foundation; either | |
| * version 2.1 of the License, or (at your option) any later version. | |
| * | |
| * This library is distributed in the hope that it will be useful, | |
| * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| * Lesser General Public License for more details. | |
| * | |
| * You should have received a copy of the GNU Lesser General Public | |
| * License along with this library; if not, write to the Free Software | |
| * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
| */ | |
| #include "config.h" | |
| #include <stdlib.h> | |
| #include <string.h> | |
| #include "windef.h" | |
| #include <EXTERN.h> | |
| #include <perl.h> | |
| #include <XSUB.h> | |
| #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); |