Sweden-Number/programs/winetest/wine.xs

530 lines
18 KiB
Plaintext

/* -*-C-*- --------------------------------------------------------------------
| Module: wine.xs |
| ---------------------------------------------------------------------------- |
| Purpose: Perl gateway to wine API calls |
| |
------------------------------------------------------------------------------*/
#include <stdlib.h>
#include <string.h>
#include "config.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
};
/* 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( 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 |
| |
| |
----------------------------------------------------------------------*/
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);