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(pTHX
)
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
);