mirror of
git://source.winehq.org/git/wine.git
synced 2024-10-31 08:49:15 +00:00
183 lines
6.5 KiB
C
183 lines
6.5 KiB
C
/*
|
|
* Perl interpreter for running Wine tests
|
|
*
|
|
* Copyright 2001 John F Sturtz for Codeweavers
|
|
*
|
|
* This library is free software; you can redistribute it and/or
|
|
* modify it under the terms of the GNU Lesser General Public
|
|
* License as published by the Free Software Foundation; either
|
|
* version 2.1 of the License, or (at your option) any later version.
|
|
*
|
|
* This library is distributed in the hope that it will be useful,
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
* Lesser General Public License for more details.
|
|
*
|
|
* You should have received a copy of the GNU Lesser General Public
|
|
* License along with this library; if not, write to the Free Software
|
|
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
*/
|
|
|
|
#include <assert.h>
|
|
#include <stdio.h>
|
|
|
|
#include "windef.h"
|
|
#include "winbase.h"
|
|
|
|
#include <EXTERN.h>
|
|
#include <perl.h>
|
|
|
|
static FARPROC pGetLastError;
|
|
|
|
/*----------------------------------------------------------------------
|
|
| Function: call_wine_func |
|
|
| -------------------------------------------------------------------- |
|
|
| Purpose: Call a wine API function, passing in appropriate number |
|
|
| of args |
|
|
| |
|
|
| Parameters: proc -- function to call |
|
|
| n_args -- array of args |
|
|
| a -- array of args |
|
|
| |
|
|
| Returns: return value from API function called |
|
|
----------------------------------------------------------------------*/
|
|
static unsigned long call_wine_func
|
|
(
|
|
FARPROC proc,
|
|
int n_args,
|
|
unsigned long *a
|
|
)
|
|
{
|
|
/* Locals */
|
|
unsigned long rc;
|
|
|
|
/* Begin call_wine_func */
|
|
|
|
/*--------------------------------------------------------------
|
|
| Now we need to call the function with the appropriate number
|
|
| of arguments
|
|
|
|
|
| Anyone who can think of a better way to do this is welcome to
|
|
| come forth with it ...
|
|
--------------------------------------------------------------*/
|
|
switch (n_args)
|
|
{
|
|
|
|
case 0: rc = proc (); break;
|
|
case 1: rc = proc (a[0]); break;
|
|
case 2: rc = proc (a[0], a[1]); break;
|
|
case 3: rc = proc (a[0], a[1], a[2]); break;
|
|
case 4: rc = proc (a[0], a[1], a[2], a[3]); break;
|
|
case 5: rc = proc (a[0], a[1], a[2], a[3], a[4]); break;
|
|
case 6: rc = proc (a[0], a[1], a[2], a[3], a[4], a[5]); break;
|
|
case 7: rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6]); break;
|
|
case 8: rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7]); break;
|
|
case 9: rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]); break;
|
|
case 10: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
|
|
a[9] ); break;
|
|
case 11: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
|
|
a[9], a[10] ); break;
|
|
case 12: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
|
|
a[9], a[10], a[11] ); break;
|
|
case 13: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
|
|
a[9], a[10], a[11], a[12] ); break;
|
|
case 14: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
|
|
a[9], a[10], a[11], a[12], a[13] ); break;
|
|
case 15: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
|
|
a[9], a[10], a[11], a[12], a[13], a[14] ); break;
|
|
case 16: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
|
|
a[9], a[10], a[11], a[12], a[13], a[14], a[15] ); break;
|
|
default:
|
|
fprintf( stderr, "%d args not supported\n", n_args );
|
|
rc = 0;
|
|
break;
|
|
}
|
|
|
|
/*--------------------------------------------------------------
|
|
| Return value from func
|
|
--------------------------------------------------------------*/
|
|
return (rc);
|
|
}
|
|
|
|
|
|
/*----------------------------------------------------------------------
|
|
| 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
|
|
----------------------------------------------------------------------*/
|
|
unsigned long perl_call_wine
|
|
(
|
|
FARPROC proc,
|
|
int n_args,
|
|
unsigned long *args,
|
|
unsigned int *last_error,
|
|
int debug
|
|
)
|
|
{
|
|
unsigned long ret;
|
|
DWORD error, old_error;
|
|
|
|
if (debug > 1)
|
|
{
|
|
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" );
|
|
}
|
|
|
|
/* 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
|
|
{
|
|
old_error = GetLastError();
|
|
SetLastError( 0xdeadbeef );
|
|
ret = call_wine_func (proc, n_args, args);
|
|
error = GetLastError();
|
|
if (error != 0xdeadbeef) *last_error = error;
|
|
else SetLastError( old_error );
|
|
}
|
|
return ret;
|
|
}
|
|
|
|
|
|
/* perl extension initialisation */
|
|
static void xs_init(pTHX)
|
|
{
|
|
extern void boot_wine(CV *cv);
|
|
newXS("wine::bootstrap", boot_wine,__FILE__);
|
|
}
|
|
|
|
/* main function */
|
|
int main( int argc, char **argv, char **envp )
|
|
{
|
|
PerlInterpreter *perl;
|
|
int status;
|
|
|
|
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" );
|
|
exit(1);
|
|
}
|
|
perl_construct (perl);
|
|
status = perl_parse( perl, xs_init, argc, argv, envp );
|
|
if (!status) status = perl_run(perl);
|
|
perl_destruct (perl);
|
|
perl_free (perl);
|
|
exit( status );
|
|
}
|