2 * Perl interpreter for running Wine tests
14 static FARPROC pGetLastError
;
16 /*----------------------------------------------------------------------
17 | Function: call_wine_func |
18 | -------------------------------------------------------------------- |
19 | Purpose: Call a wine API function, passing in appropriate number |
22 | Parameters: proc -- function to call |
23 | n_args -- array of args |
24 | a -- array of args |
26 | Returns: return value from API function called |
27 ----------------------------------------------------------------------*/
28 static unsigned long call_wine_func
38 /* Begin call_wine_func */
40 /*--------------------------------------------------------------
41 | Now we need to call the function with the appropriate number
44 | Anyone who can think of a better way to do this is welcome to
45 | come forth with it ...
46 --------------------------------------------------------------*/
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],
62 case 11: rc
= proc( a
[0], a
[1], a
[2], a
[3], a
[4], a
[5], a
[6], a
[7], a
[8],
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;
75 fprintf( stderr
, "%d args not supported\n", n_args
);
80 /*--------------------------------------------------------------
81 | Return value from func
82 --------------------------------------------------------------*/
87 /*----------------------------------------------------------------------
88 | Function: perl_call_wine
89 | --------------------------------------------------------------------
90 | Purpose: Fetch and call a wine API function from a library
94 | proc -- function address
95 | n_args -- number of args
97 | last_error -- returns the last error code
100 | Returns: Return value from API function called
101 ----------------------------------------------------------------------*/
102 unsigned long perl_call_wine
107 unsigned int *last_error
,
112 DWORD error
, old_error
;
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" );
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
);
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
);
138 /* perl extension initialisation */
139 static void xs_init(void)
141 extern void boot_wine(CV
*cv
);
142 newXS("wine::bootstrap", boot_wine
,__FILE__
);
146 int main( int argc
, char **argv
, char **envp
)
148 PerlInterpreter
*perl
;
151 envp
= environ
; /* envp is not valid (yet) in Winelib */
153 pGetLastError
= GetProcAddress( GetModuleHandleA("kernel32"), "GetLastError" );
154 assert( pGetLastError
);
156 if (!(perl
= perl_alloc ()))
158 fprintf( stderr
, "Could not allocate perl interpreter\n" );
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
);