Added first version of the Perl regression testing framework.

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

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

programs/Makefile.in

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

programs/winetest/.cvsignore

+Makefile
+Makefile.perl
+wine.c
+winetest.spec.c

programs/winetest/Makefile.PL

+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' 
+);

programs/winetest/Makefile.in

+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:

programs/winetest/Makefile.win32

+# 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

programs/winetest/test.pl

+#
+# 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/ );

programs/winetest/winetest.c

+/*
+ * 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 );
+}

programs/winetest/winetest.spec

+name	winetest
+mode	cuiexe
+type	win32
+
+import	kernel32.dll
+import	ntdll.dll