Sweden-Number/programs/winetest/winetest.c

/*
 * Perl interpreter for running Wine tests
 *
 * Copyright 2001 John F Sturtz for Codeweavers
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 */

#include <assert.h>
#include <stdio.h>

#include "windef.h"
#include "winbase.h"

#include <EXTERN.h>
#include <perl.h>

static FARPROC pGetLastError;

/*----------------------------------------------------------------------
| Function:    call_wine_func                                          |
| -------------------------------------------------------------------- |
| Purpose:     Call a wine API function, passing in appropriate number |
|              of args                                                 |
|                                                                      |
| Parameters:  proc   -- function to call                              |
|              n_args -- array of args                                 |
|              a      -- array of args                                 |
|                                                                      |
| Returns:     return value from API function called                   |
----------------------------------------------------------------------*/
static unsigned long call_wine_func
(
    FARPROC        proc,
    int            n_args,
    unsigned long  *a
)
{
    /* Locals */
    unsigned long  rc;

/* Begin call_wine_func */

    /*--------------------------------------------------------------
    | Now we need to call the function with the appropriate number
    | of arguments
    |
    | Anyone who can think of a better way to do this is welcome to
    | come forth with it ...
    --------------------------------------------------------------*/
    switch (n_args)
    {

        case 0:  rc = proc (); break;
        case 1:  rc = proc (a[0]); break;
        case 2:  rc = proc (a[0], a[1]); break;
        case 3:  rc = proc (a[0], a[1], a[2]); break;
        case 4:  rc = proc (a[0], a[1], a[2], a[3]); break;
        case 5:  rc = proc (a[0], a[1], a[2], a[3], a[4]); break;
        case 6:  rc = proc (a[0], a[1], a[2], a[3], a[4], a[5]); break;
        case 7:  rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6]); break;
        case 8:  rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7]); break;
        case 9:  rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]); break;
        case 10: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
                            a[9] ); break;
        case 11: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
                            a[9], a[10] ); break;
        case 12: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
                            a[9], a[10], a[11] ); break;
        case 13: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
                            a[9], a[10], a[11], a[12] ); break;
        case 14: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
                            a[9], a[10], a[11], a[12], a[13] ); break;
        case 15: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
                            a[9], a[10], a[11], a[12], a[13], a[14] ); break;
        case 16: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
                            a[9], a[10], a[11], a[12], a[13], a[14], a[15] ); break;
        default:
            fprintf( stderr, "%d args not supported\n", n_args );
            rc = 0;
            break;
    }

    /*--------------------------------------------------------------
    | Return value from func
    --------------------------------------------------------------*/
    return (rc);
}


/*----------------------------------------------------------------------
| Function:    perl_call_wine
| --------------------------------------------------------------------
| Purpose:     Fetch and call a wine API function from a library
|
| Parameters:
|
|     proc       -- function address
|     n_args     -- number of args
|     args       -- args
|     last_error -- returns the last error code
|     debug      -- debug flag
|
| Returns:     Return value from API function called
----------------------------------------------------------------------*/
unsigned long perl_call_wine
(
    FARPROC        proc,
    int            n_args,
    unsigned long  *args,
    unsigned int   *last_error,
    int            debug
)
{
    unsigned long ret;
    DWORD error, old_error;

    if (debug > 1)
    {
        int i;
        fprintf(stderr,"    perl_call_wine(func=%p", proc);
        for (i = 0; i < n_args; i++) fprintf( stderr, ",0x%lx", args[i] );
        fprintf( stderr, ")\n" );
    }

    /* special case to allow testing GetLastError without messing up the last error code */
    if (proc == pGetLastError)
        ret = call_wine_func (proc, n_args, args);
    else
    {
        old_error = GetLastError();
        SetLastError( 0xdeadbeef );
        ret = call_wine_func (proc, n_args, args);
        error = GetLastError();
        if (error != 0xdeadbeef) *last_error = error;
        else SetLastError( old_error );
    }
    return ret;
}


/* perl extension initialisation */
static void xs_init(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 */

    pGetLastError = GetProcAddress( GetModuleHandleA("kernel32"), "GetLastError" );
    assert( pGetLastError );

    if (!(perl = perl_alloc ()))
    {
        fprintf( stderr, "Could not allocate perl interpreter\n" );
        exit(1);
    }
    perl_construct (perl);
    status = perl_parse( perl, xs_init, argc, argv, envp );
    if (!status) status = perl_run(perl);
    perl_destruct (perl);
    perl_free (perl);
    exit( status );
}