Store the function pointer in the %prototypes hash instead of the
function name to avoid looking it up on every call.
Fixed callback thunks to use stdcall calling convention.
diff --git a/programs/winetest/test.pl b/programs/winetest/test.pl
index 89cce69..2b67384 100644
--- a/programs/winetest/test.pl
+++ b/programs/winetest/test.pl
@@ -16,6 +16,8 @@
GlobalGetAtomNameA => "int",
GetCurrentThread => "int",
GetExitCodeThread => "int",
+ GetModuleHandleA => "int",
+ GetProcAddress => "int",
lstrcatA => "ptr"
);
@@ -59,8 +61,12 @@
eval { SetLastError(1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7); };
assert( $@ =~ /Too many arguments at/ );
-eval { wine::call_wine_API( "kernel32", "SetLastError", 10, $wine::debug, 0); };
+my $funcptr = GetProcAddress( GetModuleHandleA("kernel32"), "SetLastError" );
+assert( $funcptr );
+eval { wine::call_wine_API( $funcptr, 10, $wine::debug, 0); };
assert( $@ =~ /Bad return type 10 at/ );
eval { foobar(1,2,3); };
assert( $@ =~ /Function 'foobar' not declared at/ );
+
+print "OK\n";
diff --git a/programs/winetest/wine.pm b/programs/winetest/wine.pm
index 9845e6c..3b13c2e 100644
--- a/programs/winetest/wine.pm
+++ b/programs/winetest/wine.pm
@@ -34,6 +34,8 @@
$wine::err = 0;
$wine::debug = 0;
+%loaded_modules = ();
+
# --------------------------------------------------------------
# | Return-type constants |
# | |
@@ -85,8 +87,7 @@
# --------------------------------------------------------------
if (defined($prototypes{$func}))
{
- my ($module,$ret_type) = @{$prototypes{$func}};
- return call( $module, $func, $ret_type, $wine::debug, @_ );
+ return call( $func, $wine::debug, @_ );
}
die "Function '$func' not declared";
} # End AUTOLOAD
@@ -98,74 +99,41 @@
# | -------------------------------------------------------------------- |
# | Purpose: Call a wine API function |
# | |
-# | Usage: call MODULE, FUNCTION, RET_TYPE, DEBUG, [ARGS ...] |
+# | Usage: call FUNCTION, DEBUG, [ARGS ...]
# | |
# | Returns: value returned by API function called |
# ------------------------------------------------------------------------
sub call
{
- # ----------------------------------------------
- # | Locals |
- # ----------------------------------------------
- my ($module,$function,$ret_type,$debug,@args) = @_;
+ my ($function,$debug,@args) = @_;
+ my ($funcptr,$ret_type) = @{$prototypes{$function}};
-# Begin call
-
- $ret_type = $return_types{$ret_type};
-
- # --------------------------------------------------------------
- # | Debug |
- # --------------------------------------------------------------
if ($debug)
{
- my $z = "[$module.$function() / " . scalar (@args) . " arg(s)]";
- print STDERR "=== $z ", ("=" x (75 - length ($z))), "\n";
- print STDERR " [wine.pm/obj->call()]\n";
+ print STDERR "==== [$function() / " . scalar (@args) . " arg(s)]";
for (@args)
{
- print STDERR " ", +(ref () ? ("(" . ${$_} . ")") : "$_"), "\n";
+ print STDERR " ", +(ref () ? ("(" . ${$_} . ")") : "$_");
}
+ print STDERR " ====\n";
}
- # --------------------------------------------------------------
- # | Now call call_wine_API(), which will turn around and call |
- # | the appropriate wine API function. Arguments to |
- # | call_wine_API() are: |
- # | |
- # | module_name |
- # | function_name |
- # | return_type |
- # | debug_flag |
- # | [args to pass through to wine API function] |
- # --------------------------------------------------------------
- my ($err,$r) = call_wine_API
- (
- $module,
- $function,
- $ret_type,
- $debug,
- @args
- );
+ # Now call call_wine_API(), which will turn around and call
+ # the appropriate wine API function.
+ my ($err,$r) = call_wine_API( $funcptr, $ret_type, $debug, @args );
- # --------------------------------------------------------------
- # | Debug |
- # --------------------------------------------------------------
if ($debug)
{
- my $z = "[$module.$function()] -> ";
+ my $z = "[$function()] -> ";
$z .= defined($r) ? sprintf("[0x%x/%d]", $r, $r) : "[void]";
if (defined($err)) { $z .= sprintf " err=%d", $err; }
- print STDERR "=== $z ", ("=" x (75 - length ($z))), "\n";
+ print STDERR "==== $z ====\n";
}
-
- # --------------------------------------------------------------
- # | Pass the return value back |
- # --------------------------------------------------------------
+ # Pass the return value back
$wine::err = $err;
return ($r);
-
-} # End call
+}
# ----------------------------------------------------------------------
@@ -188,7 +156,9 @@
foreach $func (keys %list)
{
- $prototypes{$func} = [ $module, $list{$func} ];
+ my $ptr = get_proc_address( $handle, $func ) or die "Could not find '$func' in '$module'";
+ my $ret_type = $return_types{$list{$func}};
+ $prototypes{$func} = [ $ptr, $ret_type ];
}
}
diff --git a/programs/winetest/wine.xs b/programs/winetest/wine.xs
index df5663d..fcb2345 100644
--- a/programs/winetest/wine.xs
+++ b/programs/winetest/wine.xs
@@ -29,8 +29,7 @@
extern unsigned long perl_call_wine
(
- char *module,
- char *function,
+ FARPROC function,
int n_args,
unsigned long *args,
unsigned int *last_error,
@@ -57,6 +56,7 @@
void *func;
BYTE leave;
BYTE ret;
+ short arg_size;
BYTE arg_types[MAX_ARGS];
};
#pragma pack(4)
@@ -96,7 +96,7 @@
/* pushl (code ref) */ 0x68, NULL,
/* call (func) */ 0xe8, NULL,
/* leave */ 0xc9,
- /* ret */ 0xc3,
+ /* ret $arg_size */ 0xc2, 0,
/* arg_types */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }
};
@@ -194,8 +194,7 @@
# --------------------------------------------------------------------
# Purpose: Call perl_call_wine(), which calls a wine API function
#
- # Parameters: module -- module (dll) to get function from
- # function -- API function to call
+ # Parameters: function -- API function to call
# ret_type -- return type
# debug -- debug flag
# ... -- args to pass to API function
@@ -204,13 +203,12 @@
# value returned by the API function
# --------------------------------------------------------------------
void
-call_wine_API(module, function, ret_type, debug, ...)
- char *module;
- char *function;
+call_wine_API(function, ret_type, debug, ...)
+ unsigned long function;
int ret_type;
int debug;
- PROTOTYPE: $$$$@
+ PROTOTYPE: $$$@
PPCODE:
/*--------------------------------------------------------------
@@ -225,7 +223,7 @@
};
/* Locals */
- int n_fixed = 4;
+ int n_fixed = 3;
int n_args = (items - n_fixed);
struct arg args[MAX_ARGS+1];
unsigned long f_args[MAX_ARGS+1];
@@ -240,7 +238,7 @@
/*--------------------------------------------------------------
| Prepare function args
--------------------------------------------------------------*/
- if (debug)
+ if (debug > 1)
{
fprintf( stderr, " [wine.xs/call_wine_API()]\n");
}
@@ -266,7 +264,7 @@
{
args[i].ival = SvIV (sv);
f_args[i] = (unsigned long) &(args[i].ival);
- if (debug)
+ if (debug > 1)
{
fprintf( stderr, " [RV->IV] 0x%lx\n", f_args[i]);
}
@@ -279,7 +277,7 @@
{
args[i].ival = (unsigned long) SvNV (sv);
f_args[i] = (unsigned long) &(args[i].ival);
- if (debug)
+ if (debug > 1)
{
fprintf( stderr, " [RV->NV] 0x%lx\n", f_args[i]);
}
@@ -291,7 +289,7 @@
else if (SvPOK (sv))
{
f_args[i] = (unsigned long) ((char *) SvPV (sv, PL_na));
- if (debug)
+ if (debug > 1)
{
fprintf( stderr, " [RV->PV] 0x%lx\n", f_args[i]);
}
@@ -310,7 +308,7 @@
if (SvIOK (sv))
{
f_args[i] = (unsigned long) SvIV (sv);
- if (debug)
+ if (debug > 1)
{
fprintf( stderr, " [IV] %ld (0x%lx)\n", f_args[i], f_args[i]);
}
@@ -322,7 +320,7 @@
else if (SvNOK (sv))
{
f_args[i] = (unsigned long) SvNV (sv);
- if (debug)
+ if (debug > 1)
{
fprintf( stderr, " [NV] %ld (0x%lx)\n", f_args[i], f_args[i]);
}
@@ -340,7 +338,7 @@
((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)
+ if (debug > 1)
{
fprintf( stderr, " [PV] 0x%lx\n", f_args[i]);
}
@@ -353,15 +351,7 @@
/*--------------------------------------------------------------
| Here we go
--------------------------------------------------------------*/
- r = perl_call_wine
- (
- module,
- function,
- n_args,
- f_args,
- &last_error,
- debug
- );
+ r = perl_call_wine( (FARPROC)function, n_args, f_args, &last_error, debug );
/*--------------------------------------------------------------
| Handle modified parameter values
@@ -439,6 +429,24 @@
# --------------------------------------------------------------------
+ # 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
@@ -504,6 +512,7 @@
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));
diff --git a/programs/winetest/winetest.c b/programs/winetest/winetest.c
index 8e7b233..0543f0b 100644
--- a/programs/winetest/winetest.c
+++ b/programs/winetest/winetest.c
@@ -2,6 +2,7 @@
* Perl interpreter for running Wine tests
*/
+#include <assert.h>
#include <stdio.h>
#include "windef.h"
@@ -10,6 +11,8 @@
#include <EXTERN.h>
#include <perl.h>
+static FARPROC pGetLastError;
+
/*----------------------------------------------------------------------
| Function: call_wine_func |
| -------------------------------------------------------------------- |
@@ -82,74 +85,41 @@
/*----------------------------------------------------------------------
-| Function: perl_call_wine |
-| -------------------------------------------------------------------- |
-| Purpose: Fetch and call a wine API function from a library |
-| |
-| Parameters: |
-| |
-| module -- module in function (ostensibly) resides |
-| function -- function name |
-| n_args -- number of args |
-| args -- args |
+| Function: perl_call_wine
+| --------------------------------------------------------------------
+| Purpose: Fetch and call a wine API function from a library
+|
+| Parameters:
+|
+| proc -- function address
+| n_args -- number of args
+| args -- args
| last_error -- returns the last error code
-| debug -- debug flag |
-| |
-| Returns: Return value from API function called |
+| debug -- debug flag
+|
+| Returns: Return value from API function called
----------------------------------------------------------------------*/
unsigned long perl_call_wine
(
- char *module,
- char *function,
+ FARPROC proc,
int n_args,
unsigned long *args,
unsigned int *last_error,
int debug
)
{
- /* Locals */
- HMODULE hmod;
- FARPROC proc;
- int i;
- unsigned long ret, error, old_error;
+ unsigned long ret;
+ DWORD error, old_error;
- static FARPROC pGetLastError;
-
- /*--------------------------------------------------------------
- | Debug
- --------------------------------------------------------------*/
if (debug)
{
- fprintf(stderr," perl_call_wine(");
- for (i = 0; (i < n_args); i++)
- fprintf( stderr, "0x%lx%c", args[i], (i < n_args-1) ? ',' : ')' );
- fputc( '\n', stderr );
+ int i;
+ fprintf(stderr," perl_call_wine(func=%p", proc);
+ for (i = 0; i < n_args; i++) fprintf( stderr, ",0x%lx", args[i] );
+ fprintf( stderr, ")\n" );
}
- /*--------------------------------------------------------------
- | See if we can load specified module
- --------------------------------------------------------------*/
- if (!(hmod = GetModuleHandleA(module)))
- {
- fprintf( stderr, "GetModuleHandleA(%s) failed\n", module);
- exit(1);
- }
-
- /*--------------------------------------------------------------
- | See if we can get address of specified function from it
- --------------------------------------------------------------*/
- if ((proc = GetProcAddress (hmod, function)) == NULL)
- {
- fprintf (stderr, " GetProcAddress(%s.%s) failed\n", module, function);
- exit(1);
- }
-
- /*--------------------------------------------------------------
- | Righty then; call the function ...
- --------------------------------------------------------------*/
- if (!pGetLastError)
- pGetLastError = GetProcAddress( GetModuleHandleA("kernel32"), "GetLastError" );
-
+ /* special case to allow testing GetLastError without messing up the last error code */
if (proc == pGetLastError)
ret = call_wine_func (proc, n_args, args);
else
@@ -180,6 +150,9 @@
envp = environ; /* envp is not valid (yet) in Winelib */
+ pGetLastError = GetProcAddress( GetModuleHandleA("kernel32"), "GetLastError" );
+ assert( pGetLastError );
+
if (!(perl = perl_alloc ()))
{
fprintf( stderr, "Could not allocate perl interpreter\n" );
