| blob | fcb2345ed7183f4425bb06e35ba91132272452d3 |
1 /* -*-C-*- --------------------------------------------------------------------
2 | Module: wine.xs |
3 | ---------------------------------------------------------------------------- |
4 | Purpose: Perl gateway to wine API calls |
5 | |
6 ------------------------------------------------------------------------------*/
8 #include <stdlib.h>
9 #include <string.h>
11 #include "config.h"
12 #include "windef.h"
14 #include <EXTERN.h>
15 #include <perl.h>
16 #include <XSUB.h>
18 /* API return type constants */
19 enum ret_type
20 {
21 RET_VOID = 0,
22 RET_INT = 1,
23 RET_WORD = 2,
24 RET_PTR = 3
25 };
27 /* max arguments for a function call */
28 #define MAX_ARGS 16
30 extern unsigned long perl_call_wine
31 (
32 FARPROC function,
33 int n_args,
34 unsigned long *args,
35 unsigned int *last_error,
36 int debug
37 );
39 /* Thunk type definitions */
41 #ifdef __i386__
42 #pragma pack(1)
43 struct thunk
44 {
45 BYTE pushl;
46 BYTE movl[2];
47 BYTE leal_args[3];
48 BYTE pushl_args;
49 BYTE pushl_addr;
50 BYTE *args_ptr;
51 BYTE pushl_nb_args;
52 BYTE nb_args;
53 BYTE pushl_ref;
54 SV *code_ref;
55 BYTE call;
56 void *func;
57 BYTE leave;
58 BYTE ret;
59 short arg_size;
60 BYTE arg_types[MAX_ARGS];
61 };
62 #pragma pack(4)
63 #else
64 #error You must implement the callback thunk for your CPU
65 #endif
67 /*--------------------------------------------------------------
68 | This contains most of the machine instructions necessary to
69 | implement the thunk. All the thunk does is turn around and
70 | call function callback_bridge(), which is defined in
71 | winetest.c.
72 |
73 | The data from this static thunk can just be copied directly
74 | into the thunk allocated dynamically below. That fills in
75 | most of it, but a couple values need to be filled in after
76 | the allocation, at run time:
77 |
78 | 1) The pointer to the thunk's data area, which we
79 | don't know yet, because we haven't allocated it
80 | yet ...
81 |
82 | 2) The address of the function to call. We know the
83 | address of the function [callback_bridge()], but
84 | the value filled into the thunk is an address
85 | relative to the thunk itself, so we can't fill it
86 | in until we've allocated the actual thunk.
87 --------------------------------------------------------------*/
88 static const struct thunk thunk_template =
89 {
90 /* pushl %ebp */ 0x55,
91 /* movl %esp,%ebp */ { 0x89, 0xe5 },
92 /* leal 8(%ebp),%edx */ { 0x8d, 0x55, 0x08 },
93 /* pushl %edx */ 0x52,
94 /* pushl (data addr) */ 0x68, NULL,
95 /* pushl (nb_args) */ 0x6a, 0,
96 /* pushl (code ref) */ 0x68, NULL,
97 /* call (func) */ 0xe8, NULL,
98 /* leave */ 0xc9,
99 /* ret $arg_size */ 0xc2, 0,
100 /* arg_types */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }
101 };
104 /*----------------------------------------------------------------------
105 | Function: convert_value |
106 | -------------------------------------------------------------------- |
107 | Purpose: Convert a C value to a Perl value |
108 | |
109 | Parameters: type -- constant specifying type of value |
110 | val -- value to convert |
111 | |
112 | Returns: Perl SV * |
113 ----------------------------------------------------------------------*/
114 static SV *convert_value( enum ret_type type, unsigned long val )
115 {
116 switch (type)
117 {
118 case RET_VOID: return &PL_sv_undef;
119 case RET_INT: return sv_2mortal( newSViv ((int) val ));
120 case RET_WORD: return sv_2mortal( newSViv ((int) val & 0xffff ));
121 case RET_PTR: return sv_2mortal( newSVpv ((char *) val, 0 ));
123 default:
124 croak ("Bad return type %d", type);
125 break;
126 }
127 }
130 /*----------------------------------------------------------------------
131 | Function: callback_bridge |
132 | -------------------------------------------------------------------- |
133 | Purpose: Central pass-through point for Wine API callbacks |
134 | |
135 | Wine API callback thunks are set up so that they call this |
136 | function, which turns around and calls the user's declared |
137 | Perl callback sub. |
138 | |
139 | Parameters: data -- pointer to thunk data area |
140 | args -- array of args passed from Wine API to callback |
141 | |
142 | Returns: Whatever the Perl sub returns |
143 ----------------------------------------------------------------------*/
144 static int callback_bridge( SV *callback_ref, int nb_args, BYTE arg_types[], unsigned long args[] )
145 {
146 /* Locals */
147 int i, n;
148 SV *sv;
150 int r = 0;
152 /* Perl/C interface voodoo */
153 dSP;
154 ENTER;
155 SAVETMPS;
156 PUSHMARK(sp);
158 /* Push args on stack, according to type */
159 for (i = 0; i < nb_args; i++)
160 {
161 sv = convert_value (arg_types[i], args[i]);
162 PUSHs (sv);
163 }
164 PUTBACK;
166 /* Call Perl sub */
167 n = perl_call_sv (callback_ref, G_SCALAR);
169 /* Nab return value */
170 SPAGAIN;
171 if (n == 1)
172 {
173 r = POPi;
174 }
175 PUTBACK;
176 FREETMPS;
177 LEAVE;
179 /* [todo] Pass through Perl sub return value */
180 return (r);
181 }
184 /*----------------------------------------------------------------------
185 | XS module |
186 | |
187 | |
188 ----------------------------------------------------------------------*/
189 MODULE = wine PACKAGE = wine
192 # --------------------------------------------------------------------
193 # Function: call_wine_API
194 # --------------------------------------------------------------------
195 # Purpose: Call perl_call_wine(), which calls a wine API function
196 #
197 # Parameters: function -- API function to call
198 # ret_type -- return type
199 # debug -- debug flag
200 # ... -- args to pass to API function
201 #
202 # Returns: list containing 2 elements: the last error code and the
203 # value returned by the API function
204 # --------------------------------------------------------------------
205 void
206 call_wine_API(function, ret_type, debug, ...)
207 unsigned long function;
208 int ret_type;
209 int debug;
211 PROTOTYPE: $$$@
213 PPCODE:
214 /*--------------------------------------------------------------
215 | Begin call_wine_API
216 --------------------------------------------------------------*/
218 /* Local types */
219 struct arg
220 {
221 int ival;
222 void *pval;
223 };
225 /* Locals */
226 int n_fixed = 3;
227 int n_args = (items - n_fixed);
228 struct arg args[MAX_ARGS+1];
229 unsigned long f_args[MAX_ARGS+1];
230 unsigned int i, n;
231 unsigned int last_error = 0xdeadbeef;
232 char *p;
233 SV *sv;
234 unsigned long r;
236 if (n_args > MAX_ARGS) croak("Too many arguments");
238 /*--------------------------------------------------------------
239 | Prepare function args
240 --------------------------------------------------------------*/
241 if (debug > 1)
242 {
243 fprintf( stderr, " [wine.xs/call_wine_API()]\n");
244 }
245 for (i = 0; (i < n_args); i++)
246 {
247 sv = ST (n_fixed + i);
248 args[i].pval = NULL;
250 if (! SvOK (sv))
251 continue;
253 /*--------------------------------------------------------------
254 | Ref
255 --------------------------------------------------------------*/
256 if (SvROK (sv))
257 {
258 sv = SvRV (sv);
260 /*--------------------------------------------------------------
261 | Integer ref -- pass address of value
262 --------------------------------------------------------------*/
263 if (SvIOK (sv))
264 {
265 args[i].ival = SvIV (sv);
266 f_args[i] = (unsigned long) &(args[i].ival);
267 if (debug > 1)
268 {
269 fprintf( stderr, " [RV->IV] 0x%lx\n", f_args[i]);
270 }
271 }
273 /*--------------------------------------------------------------
274 | Number ref -- convert and pass address of value
275 --------------------------------------------------------------*/
276 else if (SvNOK (sv))
277 {
278 args[i].ival = (unsigned long) SvNV (sv);
279 f_args[i] = (unsigned long) &(args[i].ival);
280 if (debug > 1)
281 {
282 fprintf( stderr, " [RV->NV] 0x%lx\n", f_args[i]);
283 }
284 }
286 /*--------------------------------------------------------------
287 | String ref -- pass pointer
288 --------------------------------------------------------------*/
289 else if (SvPOK (sv))
290 {
291 f_args[i] = (unsigned long) ((char *) SvPV (sv, PL_na));
292 if (debug > 1)
293 {
294 fprintf( stderr, " [RV->PV] 0x%lx\n", f_args[i]);
295 }
296 }
297 }
299 /*--------------------------------------------------------------
300 | Scalar
301 --------------------------------------------------------------*/
302 else
303 {
305 /*--------------------------------------------------------------
306 | Integer -- pass value
307 --------------------------------------------------------------*/
308 if (SvIOK (sv))
309 {
310 f_args[i] = (unsigned long) SvIV (sv);
311 if (debug > 1)
312 {
313 fprintf( stderr, " [IV] %ld (0x%lx)\n", f_args[i], f_args[i]);
314 }
315 }
317 /*--------------------------------------------------------------
318 | Number -- convert and pass value
319 --------------------------------------------------------------*/
320 else if (SvNOK (sv))
321 {
322 f_args[i] = (unsigned long) SvNV (sv);
323 if (debug > 1)
324 {
325 fprintf( stderr, " [NV] %ld (0x%lx)\n", f_args[i], f_args[i]);
326 }
327 }
329 /*--------------------------------------------------------------
330 | String -- pass pointer to copy
331 --------------------------------------------------------------*/
332 else if (SvPOK (sv))
333 {
334 p = SvPV (sv, n);
335 if ((args[i].pval = malloc( n+2 )))
336 {
337 memcpy (args[i].pval, p, n);
338 ((char *)(args[i].pval))[n] = 0; /* add final NULL */
339 ((char *)(args[i].pval))[n+1] = 0; /* and another one for Unicode too */
340 f_args[i] = (unsigned long) args[i].pval;
341 if (debug > 1)
342 {
343 fprintf( stderr, " [PV] 0x%lx\n", f_args[i]);
344 }
345 }
346 }
347 }
349 } /* end for */
351 /*--------------------------------------------------------------
352 | Here we go
353 --------------------------------------------------------------*/
354 r = perl_call_wine( (FARPROC)function, n_args, f_args, &last_error, debug );
356 /*--------------------------------------------------------------
357 | Handle modified parameter values
358 |
359 | There are four possibilities for parameter values:
360 |
361 | 1) integer value
362 | 2) string value
363 | 3) ref to integer value
364 | 4) ref to string value
365 |
366 | In cases 1 and 2, the intent is that the values won't be
367 | modified, because they're not passed by ref. So we leave
368 | them alone here.
369 |
370 | In case 4, the address of the actual string buffer has
371 | already been passed to the wine API function, which had
372 | opportunity to modify it if it wanted to. So again, we
373 | don't have anything to do here.
374 |
375 | The case we need to handle is case 3. For integers passed
376 | by ref, we created a local containing the initial value,
377 | and passed its address to the wine API function, which
378 | (potentially) modified it. Now we have to copy the
379 | (potentially) new value back to the Perl variable passed
380 | in, using sv_setiv(). (Which will take fewer lines of code
381 | to do than it took lines of comment to describe ...)
382 --------------------------------------------------------------*/
383 for (i = 0; (i < n_args); i++)
384 {
385 sv = ST (n_fixed + i);
386 if (! SvOK (sv))
387 continue;
388 if (SvROK (sv) && (sv = SvRV (sv)) && SvIOK (sv))
389 {
390 sv_setiv (sv, args[i].ival);
391 }
392 }
394 /*--------------------------------------------------------------
395 | Put appropriate return value on the stack for Perl to pick
396 | up
397 --------------------------------------------------------------*/
398 EXTEND(SP,2);
399 if (last_error != 0xdeadbeef) PUSHs(sv_2mortal(newSViv(last_error)));
400 else PUSHs( &PL_sv_undef );
401 PUSHs (convert_value (ret_type, r));
403 /*--------------------------------------------------------------
404 | Free up allocated memory
405 --------------------------------------------------------------*/
406 for (i = 0; (i < n_args); i++)
407 {
408 if (args[i].pval) free(args[i].pval);
409 }
412 # --------------------------------------------------------------------
413 # Function: load_library
414 # --------------------------------------------------------------------
415 # Purpose: Load a Wine library
416 #
417 # Parameters: module -- module (dll) to load
418 #
419 # Returns: module handle
420 # --------------------------------------------------------------------
421 void
422 load_library(module)
423 char *module;
424 PROTOTYPE: $
426 PPCODE:
427 ST(0) = newSViv( (I32)LoadLibraryA(module) );
428 XSRETURN(1);
431 # --------------------------------------------------------------------
432 # Function: get_proc_address
433 # --------------------------------------------------------------------
434 # Purpose: Retrive a function address
435 #
436 # Parameters: module -- module handle
437 # --------------------------------------------------------------------
438 void
439 get_proc_address(module,func)
440 unsigned long module;
441 char *func;
442 PROTOTYPE: $$
444 PPCODE:
445 ST(0) = newSViv( (I32)GetProcAddress( (HMODULE)module, func ) );
446 XSRETURN(1);
449 # --------------------------------------------------------------------
450 # Function: alloc_thunk
451 # --------------------------------------------------------------------
452 # Purpose: Allocate a thunk for a wine API callback
453 #
454 # This is used when a Wine API function is called from Perl, and
455 # that API function takes a callback as one of its parameters.
456 #
457 # The Wine API function, of course, must be passed the address of
458 # a C function as the callback. But if the API is called from Perl,
459 # we want the user to be able to specify a Perl sub as the callback,
460 # and have control returned there each time the callback is called.
461 #
462 # This function takes a code ref to a Perl sub as one of its
463 # arguments. It then creates a unique C function (a thunk) on the
464 # fly, which can be passed to the Wine API function as its callback.
465 #
466 # The thunk has its own data area (as thunks are wont to do); one
467 # of the things stashed there is aforementioned Perl code ref. So
468 # the sequence of events is as follows:
469 #
470 # 1) From Perl, user calls alloc_callback(), passing a ref
471 # to a Perl sub to use as the callback.
472 #
473 # 2) alloc_callback() calls this routine. This routine
474 # creates a thunk, and stashes the above code ref in
475 # it. This function then returns a pointer to the thunk
476 # to Perl.
477 #
478 # 3) From Perl, user calls Wine API function. As the parameter
479 # which is supposed to be the address of the callback, the
480 # user passes the pointer to the thunk allocated above.
481 #
482 # 4) The Wine API function gets called. It periodically calls
483 # the callback, which executes the thunk.
484 #
485 # 5) Each time the thunk is executed, it calls callback_bridge()
486 # (defined in winetest.c).
487 #
488 # 6) callback_bridge() fishes the Perl code ref out of the
489 # thunk data area and calls the Perl callback.
490 #
491 # Voila. The Perl callback gets called each time the Wine API
492 # function calls its callback.
493 #
494 # Parameters: [todo] Parameters ...
495 #
496 # Returns: Pointer to thunk
497 # --------------------------------------------------------------------
498 void
499 alloc_thunk(...)
501 PPCODE:
503 /* Locals */
504 struct thunk *thunk;
505 int i;
507 /* Allocate the thunk */
508 if (!(thunk = malloc( sizeof(*thunk) ))) croak( "Out of memory" );
510 (*thunk) = thunk_template;
511 thunk->args_ptr = thunk->arg_types;
512 thunk->nb_args = items - 1;
513 thunk->code_ref = SvRV (ST (0));
514 thunk->func = (void *)((char *) callback_bridge - (char *) &thunk->leave);
515 thunk->arg_size = thunk->nb_args * sizeof(int);
517 /* Stash callback arg types */
518 for (i = 1; i < items; i++) thunk->arg_types[i - 1] = SvIV (ST (i));
520 /*--------------------------------------------------------------
521 | Push the address of the thunk on the stack for return
522 |
523 | [todo] We need to free up the memory allocated somehow ...
524 --------------------------------------------------------------*/
525 ST (0) = newSViv ((I32) thunk);
526 XSRETURN (1);