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