Added support for callback functions.
This commit is contained in:
John F Sturtz
Alexandre Julliard
parent
282bdb3564
commit
5dabda3d55
|
|
@ -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'
|
||||
);
|
||||
|
|
|
|||
|
|
@ -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@
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 => <module_name>, |
|
||||
# | function => <function_name>, |
|
||||
# | ret_type => <int|ptr>, |
|
||||
# | args => [ <arg1>, <arg2>, ... ] |
|
||||
# | ) |
|
||||
# | 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 |
|
||||
# | |
|
||||
|
|
|
|||
|
|
@ -3,18 +3,19 @@
|
|||
| ---------------------------------------------------------------------------- |
|
||||
| Purpose: Perl gateway to wine API calls |
|
||||
| |
|
||||
| Functions: |
|
||||
| call_wine_API -- call a wine API function |
|
||||
| |
|
||||
------------------------------------------------------------------------------*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
#include "config.h"
|
||||
#include "windef.h"
|
||||
|
||||
#include <EXTERN.h>
|
||||
#include <perl.h>
|
||||
#include <XSUB.h>
|
||||
|
||||
/* 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);
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue