ReceiveTempSMS
/
Sweden-Number
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added first version of the Perl regression testing framework.

This commit is contained in:
Alexandre Julliard 2001-03-21 21:41:27 +00:00
parent fde1b0cb0c
commit fc68434791
12 changed files with 1180 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
configure vendored
View File

@ -6939,6 +6939,7 @@ programs/uninstaller/Makefile
programs/view/Makefile
programs/wcmd/Makefile
programs/winemine/Makefile
programs/winetest/Makefile
programs/winhelp/Makefile
programs/winver/Makefile
relay32/Makefile
@ -7182,6 +7183,7 @@ programs/uninstaller/Makefile
programs/view/Makefile
programs/wcmd/Makefile
programs/winemine/Makefile
programs/winetest/Makefile
programs/winhelp/Makefile
programs/winver/Makefile
relay32/Makefile

1
configure.in
View File

@ -1226,6 +1226,7 @@ programs/uninstaller/Makefile
programs/view/Makefile
programs/wcmd/Makefile
programs/winemine/Makefile
programs/winetest/Makefile
programs/winhelp/Makefile
programs/winver/Makefile
relay32/Makefile

1
programs/Makefile.in
View File

@ -18,6 +18,7 @@ SUBDIRS = \
view \
wcmd \
winemine \
winetest \
winhelp \
winver

4
programs/winetest/.cvsignore Normal file
View File

@ -0,0 +1,4 @@
Makefile
Makefile.perl
wine.c
winetest.spec.c

11
programs/winetest/Makefile.PL Normal file
View File

@ -0,0 +1,11 @@
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
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'
);

34
programs/winetest/Makefile.in Normal file
View File

@ -0,0 +1,34 @@
EXTRADEFS = -DSTRICT `perl -MExtUtils::Embed -e ccflags`
EXTRALIBS = `perl -MExtUtils::Embed -e ldopts`
EXTRAINCL = `perl -MExtUtils::Embed -e perl_inc`
TOPSRCDIR = @top_srcdir@
TOPOBJDIR = ../..
SRCDIR = @srcdir@
VPATH = @srcdir@
MODULE = winetest
C_SRCS = winetest.c
EXTRA_OBJS = wine.o
PERLMAKE = $(MAKE) -fMakefile.perl
@MAKE_PROG_RULES@
wine.o: wine.xs Makefile.perl
$(PERLMAKE) wine.o
Makefile.perl: Makefile.PL
perl Makefile.PL
install::
[ -d $(libdir) ] || $(MKDIR) $(libdir)
$(INSTALL_DATA) wine.pm $(libdir)/wine.pm
uninstall::
cd $(libdir) && $(RM) wine.pm
clean:: Makefile.perl
$(PERLMAKE) realclean
### Dependencies:

27
programs/winetest/Makefile.win32 Normal file
View File

@ -0,0 +1,27 @@
# Set this to the directory containing perl includes and libraries
PERLDIR = c:\perl\5.6.0\lib\MSWin32-x86\CORE
CC = cl -c
CFLAGS = -DWIN32 -D_X86_ -I$(PERLDIR)
PERLLIB = -libpath:$(PERLDIR) perl56.lib
PERLMAKE = $(MAKE) /fMakefile.perl
OBJS = winetest.obj wine.obj
all: winetest.exe
winetest.exe: $(OBJS)
link -out:$@ $(LDFLAGS) $(OBJS) $(PERLLIB)
winetest.obj: winetest.c
$(CC) $(CFLAGS) winetest.c
wine.obj: wine.xs Makefile.perl
$(PERLMAKE) wine.obj
Makefile.perl: Makefile.PL
perl Makefile.PL
clean: Makefile.perl
del winetest.exe $(OBJS)
$(PERLMAKE) realclean

66
programs/winetest/test.pl Normal file
View File

@ -0,0 +1,66 @@
#
# Test script for the winetest program
#
use wine;
$wine::debug = 0;
################################################################
# Declarations for functions we use in this script
wine::declare( "kernel32",
SetLastError => "void",
GetLastError => "int",
GlobalAddAtomA => "word",
GlobalGetAtomNameA => "int",
GetCurrentThread => "int",
GetExitCodeThread => "int",
lstrcatA => "ptr"
);
################################################################
# Test some simple function calls
# Test string arguments
$atom = GlobalAddAtomA("foo");
assert( $atom >= 0xc000 && $atom <= 0xffff );
assert( !defined($wine::err) );
# Test integer and string reference arguments
$buffer = "xxxxxx";
$ret = GlobalGetAtomNameA( $atom, \$buffer, length(buffer) );
assert( !defined($wine::err) );
assert( $ret == 3 );
assert( lc $buffer eq "foo\000xx" );
# Test integer reference
$code = 0;
$ret = GetExitCodeThread( GetCurrentThread(), \$code );
assert( !defined($wine::err) );
assert( $ret );
assert( $code == 0x103 );
# Test string return value
$str = lstrcatA( "foo\0foo", "bar" );
assert( !defined($wine::err) );
assert( $str eq "foobar" );
################################################################
# Test last error handling
SetLastError( 123 );
$ret = GetLastError();
assert( $ret == 123 );
################################################################
# Test various error cases
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); };
assert( $@ =~ /Bad return type 10 at/ );
eval { foobar(1,2,3); };
assert( $@ =~ /Function 'foobar' not declared at/ );

528
programs/winetest/wine.pm Normal file
View File

@ -0,0 +1,528 @@
# --------------------------------------------------------------------------------
# | Module: wine.pm |
# | ---------------------------------------------------------------------------- |
# | 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);
require 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
);
$VERSION = '0.01';
bootstrap wine $VERSION;
# Global variables
$wine::err = 0;
$wine::debug = 0;
# --------------------------------------------------------------
# | Return-type constants |
# | |
# | [todo] I think there's a way to define these in a C |
# | header file, so that both the C functions in the |
# | XS module and the Perl routines in the .pm have |
# | access to them. But I haven't worked it out |
# | yet ... |
# --------------------------------------------------------------
%return_types = ( "void" => 0, "int" => 1, "word" => 2, "ptr" => 3 );
# Preloaded methods go here.
# ------------------------------------------------------------------------
# | Method: new |
# | -------------------------------------------------------------------- |
# | Purpose: Object constructor |
# | |
# | Usage: $obj->new |
# | |
# | Returns: new wine object |
# ------------------------------------------------------------------------
sub AUTOLOAD
{
# --------------------------------------------------------------
# | Figure out who we are |
# --------------------------------------------------------------
my ($pkg, $func) = (split /::/, $AUTOLOAD)[0,1];
# --------------------------------------------------------------
# | Any function that is in the @EXPORT array is passed thru |
# | to AutoLoader to pick up the appropriate XS extension |
# --------------------------------------------------------------
if (grep ($_ eq $func, @EXPORT))
{
$AutoLoader::AUTOLOAD = $AUTOLOAD;
goto &AutoLoader::AUTOLOAD;
}
# --------------------------------------------------------------
# | Ignore this |
# --------------------------------------------------------------
return
if ($func eq 'DESTROY');
# --------------------------------------------------------------
# | Otherwise, assume any undefined method is the name of a |
# | wine API call, and all the args are to be passed through |
# --------------------------------------------------------------
if (defined($prototypes{$func}))
{
my ($module,$ret_type) = @{$prototypes{$func}};
return call( $module, $func, $ret_type, $wine::debug, @_ );
}
die "Function '$func' not declared";
} # End AUTOLOAD
# ------------------------------------------------------------------------
# | Method: 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>, ... ] |
# | ) |
# | |
# | Returns: value returned by API function called |
# ------------------------------------------------------------------------
sub call
{
# ----------------------------------------------
# | Locals |
# ----------------------------------------------
my ($module,$function,$ret_type,$debug,@args) = @_;
# 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";
for (@args)
{
print STDERR " ", +(ref () ? ("(" . ${$_} . ")") : "$_"), "\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
);
# --------------------------------------------------------------
# | Debug |
# --------------------------------------------------------------
if ($debug)
{
my $z = "[$module.$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";
}
# --------------------------------------------------------------
# | Pass the return value back |
# --------------------------------------------------------------
$wine::err = $err;
return ($r);
} # End call
# ----------------------------------------------------------------------
# | Subroutine: declare
# ----------------------------------------------------------------------
sub declare
{
my ($module, %list) = @_;
my ($handle, $func);
if (defined($loaded_modules{$module}))
{
$handle = $loaded_modules{$module};
}
else
{
$handle = load_library($module) or die "Could not load '$module'";
$loaded_modules{$module} = $handle;
}
foreach $func (keys %list)
{
$prototypes{$func} = [ $module, $list{$func} ];
}
}
# ----------------------------------------------------------------------
# | Subroutine: hd |
# | |
# | Purpose: Display a hex dump of a string |
# | |
# | Usage: hd STR |
# | Usage: hd STR, LENGTH |
# | |
# | Returns: (none) |
# ----------------------------------------------------------------------
sub hd
{
# Locals
my ($buf, $length);
my $first;
my ($str1, $str2, $str, $t);
my ($c, $x);
# Begin sub hd
# --------------------------------------------------------------
# | Get args; if no BUF specified, blow |
# --------------------------------------------------------------
$buf = shift;
$length = (shift or length ($buf));
return
if ((not defined ($buf)) || ($length <= 0));
# --------------------------------------------------------------
# | Initialize |
# --------------------------------------------------------------
$first = 1;
$str1 = "00000:";
$str2 = "";
# --------------------------------------------------------------
# | For each character |
# --------------------------------------------------------------
for (0 .. ($length - 1))
{
$c = substr ($buf, $_, 1);
$x = sprintf ("%02x", ord ($c));
$str1 .= (" " . $x);
$str2 .= (((ord ($c) >= 33) && (ord ($c) <= 126)) ? $c : ".");
# --------------------------------------------------------------
# | Every group of 4, add an extra space |
# --------------------------------------------------------------
if
(
((($_ + 1) % 16) == 4) ||
((($_ + 1) % 16) == 12)
)
{
$str1 .= " ";
$str2 .= " ";
}
# --------------------------------------------------------------
# | Every group of 8, add a '-' |
# --------------------------------------------------------------
elsif
(
((($_ + 1) % 16) == 8)
)
{
$str1 .= " -";
$str2 .= " ";
}
# --------------------------------------------------------------
# | Every group of 16, dump |
# --------------------------------------------------------------
if
(
((($_ + 1) % 16) == 0) ||
($_ == ($length - 1))
)
{
$str = sprintf ("%-64s%s", $str1, $str2);
if ($first)
{
$t = ("-" x length ($str));
print " $t\n";
print " | $length bytes\n";
print " $t\n";
$first = 0;
}
print " $str\n";
$str1 = sprintf ("%05d:", ($_ + 1));
$str2 = "";
if ($_ == ($length - 1))
{
print " $t\n";
}
}
} # end for
# --------------------------------------------------------------
# | Exit point |
# --------------------------------------------------------------
return;
} # End sub hd
# ----------------------------------------------------------------------
# | Subroutine: wc |
# | |
# | Purpose: Generate unicode string |
# | |
# | Usage: wc ASCII_STRING |
# | |
# | Returns: string generated |
# ----------------------------------------------------------------------
sub wc
{
return pack("S*",unpack("C*",shift));
} # End sub wc
# ----------------------------------------------------------------------
# | Subroutine: wclen |
# | |
# | Purpose: Return length of unicode string |
# | |
# | Usage: wclen UNICODE_STRING |
# | |
# | Returns: string generated |
# ----------------------------------------------------------------------
sub wclen
{
# Locals
my $str = shift;
my ($c1, $c2, $n);
# Begin sub wclen
$n = 0;
while (length ($str) > 0)
{
$c1 = substr ($str, 0, 1, "");
$c2 = substr ($str, 0, 1, "");
(($c1 eq "\x00") && ($c2 eq "\x00")) ? last : $n++;
}
return ($n);
} # End sub wclen
# ----------------------------------------------------------------------
# | Subroutine: assert |
# | |
# | Purpose: Print warning if something fails |
# | |
# | Usage: assert CONDITION |
# | |
# | Returns: (none) |
# ----------------------------------------------------------------------
sub assert
{
# Locals
my $assertion = shift;
my ($fn, $line);
# Begin sub assert
($fn, $line) = (caller (0))[1,2];
unless ($assertion) { print "Assertion failed [$fn, line $line]\n"; exit 1; }
} # End sub assert
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
__END__
# ------------------------------------------------------------------------
# | pod documentation |
# | |
# | |
# ------------------------------------------------------------------------
=head1 NAME
wine - Perl extension for calling wine API functions
=head1 SYNOPSIS
use wine;
wine::declare( "kernel32",
SetLastError => "void",
GetLastError => "int" );
SetLastError( 1234 );
printf "%d\n", GetLastError();
=head1 DESCRIPTION
This module provides a gateway for calling Win32 API functions from
a Perl script.
=head1 CALLING WIN32 API FUNCTIONS
The functions you want to call must first be declared by calling
the wine::declare method. The first argument is the name of the
module containing the APIs, and the next argument is a list of
function names and their return types. For instance:
wine::declare( "kernel32",
SetLastError => "void",
GetLastError => "int" );
declares that the functions SetLastError and GetLastError are
contained in the kernel32 dll.
Once you have done that you can call the functions directly just
like native Perl functions:
SetLastError( $some_error );
The supported return types are:
=over 4
=item void
=item word
=item int
=item ptr
=back
=head1 $wine::err VARIABLE
In the Win32 API, an integer error code is maintained which always
contains the status of the last API function called. In C code,
it is accessed via the GetLastError() function. From a Perl script,
it can be accessed via the package global $wine::err. For example:
GlobalGetAtomNameA ($atom, \$buf, -1);
if ($wine::err == 234)
{
...
}
Wine returns 234 (ERROR_MORE_DATA) from the GlobalGetAtomNameA()
API function in this case because the buffer length passed is -1
(hardly enough room to store anything in ...)
If the called API didn't set the last error code, $wine:;err is
undefined.
=head1 $wine::debug VARIABLE
This variable can be set to 1 to enable debugging of the API calls,
which will print a lot of information about what's going on inside the
wine package while calling an API function.
=head1 OTHER USEFUL FUNCTIONS
The bundle that includes the wine extension also includes a module of
plain ol' Perl subroutines which are useful for interacting with wine
API functions. Currently supported functions are:
=over 4
=item hd BUF [, LENGTH]
Dump a formatted hex dump to STDOUT. BUF is a string containing
the buffer to dump; LENGTH is the length to dump (length (BUF) if
omitted). This is handy because wine often writes a null character
into the middle of a buffer, thinking that the next piece of code to
look at the buffer will be a piece of C code that will regard it as
a string terminator. Little does it know that the buffer is going
to be returned to a Perl script, which may not ...
=item wc STR
Generate and return a wide-character (Unicode) string from the given
ASCII string
=item wclen WSTR
Return the length of the given wide-character string
=item assert CONDITION
Print a message if the assertion fails (i.e., CONDITION is false),
or do nothing quietly if it is true. The message includes the script
name and line number of the assertion that failed.
=back
=head1 AUTHOR
John F Sturtz, jsturtz@codeweavers.com
=head1 SEE ALSO
wine documentation
=cut

301
programs/winetest/wine.xs Normal file
View File

@ -0,0 +1,301 @@
/* -*-C-*- --------------------------------------------------------------------
| Module: wine.xs |
| ---------------------------------------------------------------------------- |
| Purpose: Perl gateway to wine API calls |
| |
| Functions: |
| call_wine_API -- call a wine API function |
| |
------------------------------------------------------------------------------*/
#include <stdlib.h>
#include <string.h>
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
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
(
char *module,
char *function,
int n_args,
unsigned long *args,
unsigned int *last_error,
int debug
);
/*----------------------------------------------------------------------
| XS module |
| |
| |
----------------------------------------------------------------------*/
MODULE = wine PACKAGE = wine
# --------------------------------------------------------------------
# Function: call_wine_API
# --------------------------------------------------------------------
# Purpose: Call perl_call_wine(), which calls a wine API function
#
# Parameters: module -- module (dll) to get function from
# 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(module, function, ret_type, debug, ...)
char *module;
char *function;
int ret_type;
int debug;
PROTOTYPE: $$$$@
PPCODE:
/*--------------------------------------------------------------
| Begin call_wine_API
--------------------------------------------------------------*/
/* Local types */
struct arg
{
int ival;
void *pval;
};
/* Locals */
int n_fixed = 4;
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)
{
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)
{
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)
{
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)
{
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)
{
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)
{
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)
{
fprintf( stderr, " [PV] 0x%lx\n", f_args[i]);
}
}
}
}
} /* end for */
/*--------------------------------------------------------------
| Here we go
--------------------------------------------------------------*/
r = perl_call_wine
(
module,
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 );
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;
}
/*--------------------------------------------------------------
| Free up allocated memory
--------------------------------------------------------------*/
for (i = 0; (i < n_args); i++)
{
if (args[i].pval) free(args[i].pval);
}
/*--------------------------------------------------------------
| End call_wine_API
--------------------------------------------------------------*/
# --------------------------------------------------------------------
# Function: load_library
# --------------------------------------------------------------------
# Purpose: Load a Wine library
#
# Parameters: module -- module (dll) to load
#
# Returns: module handle
# --------------------------------------------------------------------
unsigned int
load_library(module)
char *module;
PROTOTYPE: $

199
programs/winetest/winetest.c Normal file
View File

@ -0,0 +1,199 @@
/*
* Perl interpreter for running Wine tests
*/
#include <stdio.h>
#include "windef.h"
#include "winbase.h"
#include <EXTERN.h>
#include <perl.h>
/*----------------------------------------------------------------------
| 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: |
| |
| module -- module in function (ostensibly) resides |
| function -- function name |
| 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
(
char *module,
char *function,
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;
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 );
}
/*--------------------------------------------------------------
| 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" );
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;
}
/* 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)
{
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 */
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 );
}

6
programs/winetest/winetest.spec Normal file
View File

@ -0,0 +1,6 @@
name winetest
mode cuiexe
type win32
import kernel32.dll
import ntdll.dll