From fc68434791565f5f3d73e2f66b68e48ebc5eff05 Mon Sep 17 00:00:00 2001 From: Alexandre Julliard Date: Wed, 21 Mar 2001 21:41:27 +0000 Subject: [PATCH] Added first version of the Perl regression testing framework. --- configure | 2 + configure.in | 1 + programs/Makefile.in | 1 + programs/winetest/.cvsignore | 4 + programs/winetest/Makefile.PL | 11 + programs/winetest/Makefile.in | 34 ++ programs/winetest/Makefile.win32 | 27 ++ programs/winetest/test.pl | 66 ++++ programs/winetest/wine.pm | 528 +++++++++++++++++++++++++++++++ programs/winetest/wine.xs | 301 ++++++++++++++++++ programs/winetest/winetest.c | 199 ++++++++++++ programs/winetest/winetest.spec | 6 + 12 files changed, 1180 insertions(+) create mode 100644 programs/winetest/.cvsignore create mode 100644 programs/winetest/Makefile.PL create mode 100644 programs/winetest/Makefile.in create mode 100644 programs/winetest/Makefile.win32 create mode 100644 programs/winetest/test.pl create mode 100644 programs/winetest/wine.pm create mode 100644 programs/winetest/wine.xs create mode 100644 programs/winetest/winetest.c create mode 100644 programs/winetest/winetest.spec diff --git a/configure b/configure index b66b7581249..bf602472853 100755 --- a/configure +++ b/configure @@ -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 diff --git a/configure.in b/configure.in index f3066bc4b0c..267b537ae60 100644 --- a/configure.in +++ b/configure.in @@ -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 diff --git a/programs/Makefile.in b/programs/Makefile.in index 79e84ebf121..a0c47c7c68c 100644 --- a/programs/Makefile.in +++ b/programs/Makefile.in @@ -18,6 +18,7 @@ SUBDIRS = \ view \ wcmd \ winemine \ + winetest \ winhelp \ winver diff --git a/programs/winetest/.cvsignore b/programs/winetest/.cvsignore new file mode 100644 index 00000000000..c98c746d1a4 --- /dev/null +++ b/programs/winetest/.cvsignore @@ -0,0 +1,4 @@ +Makefile +Makefile.perl +wine.c +winetest.spec.c diff --git a/programs/winetest/Makefile.PL b/programs/winetest/Makefile.PL new file mode 100644 index 00000000000..56677b4d985 --- /dev/null +++ b/programs/winetest/Makefile.PL @@ -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' +); diff --git a/programs/winetest/Makefile.in b/programs/winetest/Makefile.in new file mode 100644 index 00000000000..20dbffc63ad --- /dev/null +++ b/programs/winetest/Makefile.in @@ -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: diff --git a/programs/winetest/Makefile.win32 b/programs/winetest/Makefile.win32 new file mode 100644 index 00000000000..85661780069 --- /dev/null +++ b/programs/winetest/Makefile.win32 @@ -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 diff --git a/programs/winetest/test.pl b/programs/winetest/test.pl new file mode 100644 index 00000000000..89cce691b83 --- /dev/null +++ b/programs/winetest/test.pl @@ -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/ ); diff --git a/programs/winetest/wine.pm b/programs/winetest/wine.pm new file mode 100644 index 00000000000..32c7e40bd65 --- /dev/null +++ b/programs/winetest/wine.pm @@ -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 => , | +# | function => , | +# | ret_type => , | +# | args => [ , , ... ] | +# | ) | +# | | +# | 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 diff --git a/programs/winetest/wine.xs b/programs/winetest/wine.xs new file mode 100644 index 00000000000..795b062e57a --- /dev/null +++ b/programs/winetest/wine.xs @@ -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 +#include + +#include +#include +#include + +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: $ diff --git a/programs/winetest/winetest.c b/programs/winetest/winetest.c new file mode 100644 index 00000000000..13b94a3e5de --- /dev/null +++ b/programs/winetest/winetest.c @@ -0,0 +1,199 @@ +/* + * Perl interpreter for running Wine tests + */ + +#include + +#include "windef.h" +#include "winbase.h" + +#include +#include + +/*---------------------------------------------------------------------- +| 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 ); +} diff --git a/programs/winetest/winetest.spec b/programs/winetest/winetest.spec new file mode 100644 index 00000000000..3b294b11d74 --- /dev/null +++ b/programs/winetest/winetest.spec @@ -0,0 +1,6 @@ +name winetest +mode cuiexe +type win32 + +import kernel32.dll +import ntdll.dll