2 * Perl interpreter for running Wine tests
4 * Copyright 2001 John F Sturtz for Codeweavers
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public
8 * License as published by the Free Software Foundation; either
9 * version 2.1 of the License, or (at your option) any later version.
11 * This library is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 * Lesser General Public License for more details.
16 * You should have received a copy of the GNU Lesser General Public
17 * License along with this library; if not, write to the Free Software
18 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
30 static FARPROC pGetLastError;
32 /*----------------------------------------------------------------------
33 | Function: call_wine_func |
34 | -------------------------------------------------------------------- |
35 | Purpose: Call a wine API function, passing in appropriate number |
38 | Parameters: proc -- function to call |
39 | n_args -- array of args |
40 | a -- array of args |
42 | Returns: return value from API function called |
43 ----------------------------------------------------------------------*/
44 static unsigned long call_wine_func
54 /* Begin call_wine_func */
56 /*--------------------------------------------------------------
57 | Now we need to call the function with the appropriate number
60 | Anyone who can think of a better way to do this is welcome to
61 | come forth with it ...
62 --------------------------------------------------------------*/
66 case 0: rc = proc (); break;
67 case 1: rc = proc (a[0]); break;
68 case 2: rc = proc (a[0], a[1]); break;
69 case 3: rc = proc (a[0], a[1], a[2]); break;
70 case 4: rc = proc (a[0], a[1], a[2], a[3]); break;
71 case 5: rc = proc (a[0], a[1], a[2], a[3], a[4]); break;
72 case 6: rc = proc (a[0], a[1], a[2], a[3], a[4], a[5]); break;
73 case 7: rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6]); break;
74 case 8: rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7]); break;
75 case 9: rc = proc (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]); break;
76 case 10: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
78 case 11: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
80 case 12: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
81 a[9], a[10], a[11] ); break;
82 case 13: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
83 a[9], a[10], a[11], a[12] ); break;
84 case 14: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
85 a[9], a[10], a[11], a[12], a[13] ); break;
86 case 15: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
87 a[9], a[10], a[11], a[12], a[13], a[14] ); break;
88 case 16: rc = proc( a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8],
89 a[9], a[10], a[11], a[12], a[13], a[14], a[15] ); break;
91 fprintf( stderr, "%d args not supported\n", n_args );
96 /*--------------------------------------------------------------
97 | Return value from func
98 --------------------------------------------------------------*/
103 /*----------------------------------------------------------------------
104 | Function: perl_call_wine
105 | --------------------------------------------------------------------
106 | Purpose: Fetch and call a wine API function from a library
110 | proc -- function address
111 | n_args -- number of args
113 | last_error -- returns the last error code
114 | debug -- debug flag
116 | Returns: Return value from API function called
117 ----------------------------------------------------------------------*/
118 unsigned long perl_call_wine
123 unsigned int *last_error,
128 DWORD error, old_error;
133 fprintf(stderr," perl_call_wine(func=%p", proc);
134 for (i = 0; i < n_args; i++) fprintf( stderr, ",0x%lx", args[i] );
135 fprintf( stderr, ")\n" );
138 /* special case to allow testing GetLastError without messing up the last error code */
139 if (proc == pGetLastError)
140 ret = call_wine_func (proc, n_args, args);
143 old_error = GetLastError();
144 SetLastError( 0xdeadbeef );
145 ret = call_wine_func (proc, n_args, args);
146 error = GetLastError();
147 if (error != 0xdeadbeef) *last_error = error;
148 else SetLastError( old_error );
154 /* perl extension initialisation */
155 static void xs_init(void)
157 extern void boot_wine(CV *cv);
158 newXS("wine::bootstrap", boot_wine,__FILE__);
162 int main( int argc, char **argv, char **envp )
164 PerlInterpreter *perl;
167 envp = environ; /* envp is not valid (yet) in Winelib */
169 pGetLastError = GetProcAddress( GetModuleHandleA("kernel32"), "GetLastError" );
170 assert( pGetLastError );
172 if (!(perl = perl_alloc ()))
174 fprintf( stderr, "Could not allocate perl interpreter\n" );
177 perl_construct (perl);
178 status = perl_parse( perl, xs_init, argc, argv, envp );
179 if (!status) status = perl_run(perl);
180 perl_destruct (perl);