diff --git a/programs/winetest/Makefile.PL b/programs/winetest/Makefile.PL index 56677b4d985..55578a702e4 100644 --- a/programs/winetest/Makefile.PL +++ b/programs/winetest/Makefile.PL @@ -5,7 +5,4 @@ WriteMakefile( 'MAKEFILE' => 'Makefile.perl', 'NAME' => 'wine', 'VERSION_FROM' => 'wine.pm', # finds $VERSION - 'LIBS' => [''], # e.g., '-lm' - 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' - 'INC' => '', # e.g., '-I/usr/include/other' ); diff --git a/programs/winetest/Makefile.in b/programs/winetest/Makefile.in index 20dbffc63ad..46e5d5c44fd 100644 --- a/programs/winetest/Makefile.in +++ b/programs/winetest/Makefile.in @@ -11,7 +11,7 @@ C_SRCS = winetest.c EXTRA_OBJS = wine.o -PERLMAKE = $(MAKE) -fMakefile.perl +PERLMAKE = $(MAKE) -fMakefile.perl INC="$(DIVINCL)" @MAKE_PROG_RULES@ diff --git a/programs/winetest/Makefile.win32 b/programs/winetest/Makefile.win32 index 85661780069..730cb5f7f86 100644 --- a/programs/winetest/Makefile.win32 +++ b/programs/winetest/Makefile.win32 @@ -2,9 +2,9 @@ PERLDIR = c:\perl\5.6.0\lib\MSWin32-x86\CORE CC = cl -c -CFLAGS = -DWIN32 -D_X86_ -I$(PERLDIR) +CFLAGS = -DWIN32 -D_X86_ -D__i386__ -I$(PERLDIR) PERLLIB = -libpath:$(PERLDIR) perl56.lib -PERLMAKE = $(MAKE) /fMakefile.perl +PERLMAKE = $(MAKE) /fMakefile.perl "DEFINE=$(CFLAGS)" OBJS = winetest.obj wine.obj diff --git a/programs/winetest/wine.pm b/programs/winetest/wine.pm index 32c7e40bd65..9845e6c9179 100644 --- a/programs/winetest/wine.pm +++ b/programs/winetest/wine.pm @@ -3,36 +3,29 @@ # | ---------------------------------------------------------------------------- | # | Purpose: Module to supply wrapper around and support for gateway to wine | # | API functions | -# | | -# | Methods: | -# | | -# | new -- object constructor | -# | err -- return last error code | -# | call -- call wine API function | -# | | -# | There are also object accessor function implemented with AUTOLOAD | # -------------------------------------------------------------------------------- package wine; - use strict; - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD - %return_types %prototypes %loaded_modules); +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD + %return_types %prototypes %loaded_modules); - require Exporter; +require Exporter; - @ISA = qw(Exporter); +@ISA = qw(Exporter); - # Items to export into callers namespace by default. Note: do not export - # names by default without a very good reason. Use EXPORT_OK instead. - # Do not simply export all your public functions/methods/constants. - @EXPORT = qw( - AUTOLOAD - assert - hd - wc - wclen - ); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + AUTOLOAD + alloc_callback + assert + hd + wc + wclen + ); $VERSION = '0.01'; bootstrap wine $VERSION; @@ -53,16 +46,15 @@ $wine::debug = 0; %return_types = ( "void" => 0, "int" => 1, "word" => 2, "ptr" => 3 ); -# Preloaded methods go here. - # ------------------------------------------------------------------------ -# | Method: new | +# | Sub: AUTOLOAD | # | -------------------------------------------------------------------- | -# | Purpose: Object constructor | +# | Purpose: Used to catch calls to undefined routines | # | | -# | Usage: $obj->new | -# | | -# | Returns: new wine object | +# | Any routine which is called and not defined is assumed to be | +# | a call to the Wine API function of the same name. We trans- | +# | late it into a call to the call() subroutine, with FUNCTION | +# | set to the function invoked and all other args passed thru. | # ------------------------------------------------------------------------ sub AUTOLOAD { @@ -102,20 +94,11 @@ sub AUTOLOAD # ------------------------------------------------------------------------ -# | Method: call | +# | Sub: call | # | -------------------------------------------------------------------- | # | Purpose: Call a wine API function | # | | -# | Usage: call ARGS | -# | | -# | where ARGS is a hash initializer with the following format: | -# | | -# | ( | -# | module => , | -# | function => , | -# | ret_type => , | -# | args => [ , , ... ] | -# | ) | +# | Usage: call MODULE, FUNCTION, RET_TYPE, DEBUG, [ARGS ...] | # | | # | Returns: value returned by API function called | # ------------------------------------------------------------------------ @@ -210,6 +193,48 @@ sub declare } +# ------------------------------------------------------------------------ +# | Sub: alloc_callback | +# | -------------------------------------------------------------------- | +# | Purpose: Allocate a thunk for a Wine API callback function. | +# | | +# | Basically a thin wrapper over alloc_thunk(); see wine.xs for | +# | details ... | +# | | +# | Usage: alloc_callback SUB_REF, [ ARGS_TYPES ... ] | +# | | +# | Returns: Pointer to thunk allocated (as an integer value) | +# | | +# | The returned value is just a raw pointer to a block of memory | +# | allocated by the C code (cast into a Perl integer). It isn't | +# | really suitable for anything but to be passed to a wine API | +# | function ... | +# ------------------------------------------------------------------------ +sub alloc_callback +{ + # ---------------------------------------------- + # | Locals | + # | | + # | [todo] Check arg types | + # ---------------------------------------------- + my $sub_ref = shift; + my @callback_arg_types = @_; + + # [todo] Check args + # [todo] Some way of specifying args passed to callback + + # -------------------------------------------------------------- + # | Convert arg types to integers | + # -------------------------------------------------------------- + map { $_ = $return_types{$_} } @callback_arg_types; + + # -------------------------------------------------------------- + # | Pass thru to alloc_thunk() | + # -------------------------------------------------------------- + return alloc_thunk ($sub_ref, @callback_arg_types); +} + + # ---------------------------------------------------------------------- # | Subroutine: hd | # | | diff --git a/programs/winetest/wine.xs b/programs/winetest/wine.xs index 795b062e57a..df5663dffc5 100644 --- a/programs/winetest/wine.xs +++ b/programs/winetest/wine.xs @@ -3,18 +3,19 @@ | ---------------------------------------------------------------------------- | | Purpose: Perl gateway to wine API calls | | | -| Functions: | -| call_wine_API -- call a wine API function | -| | ------------------------------------------------------------------------------*/ #include #include +#include "config.h" +#include "windef.h" + #include #include #include +/* API return type constants */ enum ret_type { RET_VOID = 0, @@ -36,6 +37,149 @@ extern unsigned long perl_call_wine 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; + 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 */ 0xc3, + /* 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( newSVpv ((char *) val, 0 )); + + default: + croak ("Bad return type %d", type); + break; + } +} + + +/*---------------------------------------------------------------------- +| 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 | @@ -264,14 +408,7 @@ call_wine_API(module, function, ret_type, debug, ...) EXTEND(SP,2); if (last_error != 0xdeadbeef) PUSHs(sv_2mortal(newSViv(last_error))); else PUSHs( &PL_sv_undef ); - switch (ret_type) - { - case RET_VOID: PUSHs( &PL_sv_undef ); break; - case RET_INT: PUSHs(sv_2mortal(newSViv( (int)r ))); break; - case RET_WORD: PUSHs(sv_2mortal(newSViv( (int)r & 0xffff ))); break; - case RET_PTR: PUSHs(sv_2mortal(newSVpv( (char *)r, 0 ))); break; - default: croak( "Bad return type %d", ret_type ); break; - } + PUSHs (convert_value (ret_type, r)); /*-------------------------------------------------------------- | Free up allocated memory @@ -281,10 +418,6 @@ call_wine_API(module, function, ret_type, debug, ...) if (args[i].pval) free(args[i].pval); } - /*-------------------------------------------------------------- - | End call_wine_API - --------------------------------------------------------------*/ - # -------------------------------------------------------------------- # Function: load_library @@ -295,7 +428,90 @@ call_wine_API(module, function, ret_type, debug, ...) # # Returns: module handle # -------------------------------------------------------------------- -unsigned int +void load_library(module) char *module; PROTOTYPE: $ + + PPCODE: + ST(0) = newSViv( (I32)LoadLibraryA(module) ); + 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); + + /* 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); diff --git a/programs/winetest/winetest.c b/programs/winetest/winetest.c index 13b94a3e5de..8e7b233531f 100644 --- a/programs/winetest/winetest.c +++ b/programs/winetest/winetest.c @@ -164,11 +164,6 @@ unsigned long perl_call_wine return ret; } -/* wrapper around LoadLibraryA to be called from perl */ -unsigned int load_library( const char *module ) -{ - return (unsigned int)LoadLibraryA( module ); -} /* perl extension initialisation */ static void xs_init(void)