programs/winetest/winetest.c

   1 /*
   2  * Perl interpreter for running Wine tests
   3  */
   4
   5 #include <assert.h>
   6 #include <stdio.h>
   7
   8 #include "windef.h"
   9 #include "winbase.h"
  10
  11 #include <EXTERN.h>
  12 #include <perl.h>
  13
  14 static FARPROC pGetLastError;
  15
  16 /*----------------------------------------------------------------------
  17 | Function:    call_wine_func                                          |
  18 | -------------------------------------------------------------------- |
  19 | Purpose:     Call a wine API function, passing in appropriate number |
  20 |              of args                                                 |
  21 |                                                                      |
  22 | Parameters:  proc   -- function to call                              |
  23 |              n_args -- array of args                                 |
  24 |              a      -- array of args                                 |
  25 |                                                                      |
  26 | Returns:     return value from API function called                   |
  27 ----------------------------------------------------------------------*/
  28 static unsigned long call_wine_func
  29 (
  30     FARPROC        proc,
  31     int            n_args,
  32     unsigned long  *a
  33 )
  34 {
  35     /* Locals */
  36     unsigned long  rc;
  37
  38 /* Begin call_wine_func */
  39
  40     /*--------------------------------------------------------------
  41     | Now we need to call the function with the appropriate number
  42     | of arguments
  43     |
  44     | Anyone who can think of a better way to do this is welcome to
  45     | come forth with it ...
  46     --------------------------------------------------------------*/
  47     switch (n_args)
  48     {
  49
  50         case 0:  rc = proc (); break;
  51         case 1:  rc = proc (a[0]); break;
  52         case 2:  rc = proc (a[0], a[1]); break;
  53         case 3:  rc = proc (a[0], a[1], a[2]); break;
  54         case 4:  rc = proc (a[0], a[1], a[2], a[3]); break;
  55         case 5:  rc = proc (a[0], a[1], a[2], a[3], a[4]); break;
  56         case 6:  rc = proc (a[0], a[1], a[2], a[3], a[4], a[5]); break;
  57         case 7:  rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6]); break;
  58         case 8:  rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7]); break;
  59         case 9:  rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]); break;
  60         case 10: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
  61                             a[9] ); break;
  62         case 11: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
  63                             a[9], a[10] ); break;
  64         case 12: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
  65                             a[9], a[10], a[11] ); break;
  66         case 13: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
  67                             a[9], a[10], a[11], a[12] ); break;
  68         case 14: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
  69                             a[9], a[10], a[11], a[12], a[13] ); break;
  70         case 15: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
  71                             a[9], a[10], a[11], a[12], a[13], a[14] ); break;
  72         case 16: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
  73                             a[9], a[10], a[11], a[12], a[13], a[14], a[15] ); break;
  74         default:
  75             fprintf( stderr, "%d args not supported\n", n_args );
  76             rc = 0;
  77             break;
  78     }
  79
  80     /*--------------------------------------------------------------
  81     | Return value from func
  82     --------------------------------------------------------------*/
  83     return (rc);
  84 }
  85
  86
  87 /*----------------------------------------------------------------------
  88 | Function:    perl_call_wine
  89 | --------------------------------------------------------------------
  90 | Purpose:     Fetch and call a wine API function from a library
  91 |
  92 | Parameters:
  93 |
  94 |     proc       -- function address
  95 |     n_args     -- number of args
  96 |     args       -- args
  97 |     last_error -- returns the last error code
  98 |     debug      -- debug flag
  99 |
 100 | Returns:     Return value from API function called
 101 ----------------------------------------------------------------------*/
 102 unsigned long perl_call_wine
 103 (
 104     FARPROC        proc,
 105     int            n_args,
 106     unsigned long  *args,
 107     unsigned int   *last_error,
 108     int            debug
 109 )
 110 {
 111     unsigned long ret;
 112     DWORD error, old_error;
 113
 114     if (debug)
 115     {
 116         int i;
 117         fprintf(stderr,"    perl_call_wine(func=%p", proc);
 118         for (i = 0; i < n_args; i++) fprintf( stderr, ",0x%lx", args[i] );
 119         fprintf( stderr, ")\n" );
 120     }
 121
 122     /* special case to allow testing GetLastError without messing up the last error code */
 123     if (proc == pGetLastError)
 124         ret = call_wine_func (proc, n_args, args);
 125     else
 126     {
 127         old_error = GetLastError();
 128         SetLastError( 0xdeadbeef );
 129         ret = call_wine_func (proc, n_args, args);
 130         error = GetLastError();
 131         if (error != 0xdeadbeef) *last_error = error;
 132         else SetLastError( old_error );
 133     }
 134     return ret;
 135 }
 136
 137
 138 /* perl extension initialisation */
 139 static void xs_init(void)
 140 {
 141     extern void boot_wine(CV *cv);
 142     newXS("wine::bootstrap", boot_wine,__FILE__);
 143 }
 144
 145 /* main function */
 146 int main( int argc, char **argv, char **envp )
 147 {
 148     PerlInterpreter *perl;
 149     int status;
 150
 151     envp = environ;  /* envp is not valid (yet) in Winelib */
 152
 153     pGetLastError = GetProcAddress( GetModuleHandleA("kernel32"), "GetLastError" );
 154     assert( pGetLastError );
 155
 156     if (!(perl = perl_alloc ()))
 157     {
 158         fprintf( stderr, "Could not allocate perl interpreter\n" );
 159         exit(1);
 160     }
 161     perl_construct (perl);
 162     status = perl_parse( perl, xs_init, argc, argv, envp );
 163     if (!status) status = perl_run(perl);
 164     perl_destruct (perl);
 165     perl_free (perl);
 166     exit( status );
 167 }