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/wine.pm

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

programs/winetest/wine.xs

+/* -*-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: $

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