530 lines
18 KiB
Plaintext
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);
|