2 * Perl gateway to wine API calls
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
35 /* API return type constants */
45 /* max arguments for a function call */
48 extern unsigned long perl_call_wine
53 unsigned int *last_error,
57 /* Thunk type definitions */
78 BYTE arg_types[MAX_ARGS];
82 #error You must implement the callback thunk for your CPU
85 /*--------------------------------------------------------------
86 | This contains most of the machine instructions necessary to
87 | implement the thunk. All the thunk does is turn around and
88 | call function callback_bridge(), which is defined in
91 | The data from this static thunk can just be copied directly
92 | into the thunk allocated dynamically below. That fills in
93 | most of it, but a couple values need to be filled in after
94 | the allocation, at run time:
96 | 1) The pointer to the thunk's data area, which we
97 | don't know yet, because we haven't allocated it
100 | 2) The address of the function to call. We know the
101 | address of the function [callback_bridge()], but
102 | the value filled into the thunk is an address
103 | relative to the thunk itself, so we can't fill it
104 | in until we've allocated the actual thunk.
105 --------------------------------------------------------------*/
106 static const struct thunk thunk_template =
108 /* pushl %ebp */ 0x55,
109 /* movl %esp,%ebp */ { 0x89, 0xe5 },
110 /* leal 8(%ebp),%edx */ { 0x8d, 0x55, 0x08 },
111 /* pushl %edx */ 0x52,
112 /* pushl (data addr) */ 0x68, NULL,
113 /* pushl (nb_args) */ 0x6a, 0,
114 /* pushl (code ref) */ 0x68, NULL,
115 /* call (func) */ 0xe8, NULL,
117 /* ret $arg_size */ 0xc2, 0,
118 /* arg_types */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }
122 /*----------------------------------------------------------------------
123 | Function: convert_value |
124 | -------------------------------------------------------------------- |
125 | Purpose: Convert a C value to a Perl value |
127 | Parameters: type -- constant specifying type of value |
128 | val -- value to convert |
130 | Returns: Perl SV * |
131 ----------------------------------------------------------------------*/
132 static SV *convert_value( enum ret_type type, unsigned long val )
136 case RET_VOID: return &PL_sv_undef;
137 case RET_INT: return sv_2mortal( newSViv ((int) val ));
138 case RET_WORD: return sv_2mortal( newSViv ((int) val & 0xffff ));
139 case RET_PTR: return sv_2mortal( newSViv ((int) val ));
140 case RET_STR: return sv_2mortal( newSVpv ((char *) val, 0 ));
142 croak ("Bad return type %d", type);
147 /*----------------------------------------------------------------------
148 | Function: callback_bridge |
149 | -------------------------------------------------------------------- |
150 | Purpose: Central pass-through point for Wine API callbacks |
152 | Wine API callback thunks are set up so that they call this |
153 | function, which turns around and calls the user's declared |
154 | Perl callback sub. |
156 | Parameters: data -- pointer to thunk data area |
157 | args -- array of args passed from Wine API to callback |
159 | Returns: Whatever the Perl sub returns |
160 ----------------------------------------------------------------------*/
161 static int callback_bridge( SV *callback_ref, int nb_args, BYTE arg_types[], unsigned long args[] )
169 /* Perl/C interface voodoo */
175 /* Push args on stack, according to type */
176 for (i = 0; i < nb_args; i++)
178 sv = convert_value (arg_types[i], args[i]);
184 n = perl_call_sv (callback_ref, G_SCALAR);
186 /* Nab return value */
196 /* [todo] Pass through Perl sub return value */
201 /*----------------------------------------------------------------------
205 ----------------------------------------------------------------------*/
206 MODULE = wine PACKAGE = wine
209 # --------------------------------------------------------------------
210 # Function: call_wine_API
211 # --------------------------------------------------------------------
212 # Purpose: Call perl_call_wine(), which calls a wine API function
214 # Parameters: function -- API function to call
215 # ret_type -- return type
216 # debug -- debug flag
217 # ... -- args to pass to API function
219 # Returns: list containing 2 elements: the last error code and the
220 # value returned by the API function
221 # --------------------------------------------------------------------
223 call_wine_API(function, ret_type, debug, ...)
224 unsigned long function;
231 /*--------------------------------------------------------------
232 | Begin call_wine_API
233 --------------------------------------------------------------*/
244 int n_args = (items - n_fixed);
245 struct arg args[MAX_ARGS+1];
246 unsigned long f_args[MAX_ARGS+1];
248 unsigned int last_error = 0xdeadbeef;
253 if (n_args > MAX_ARGS) croak("Too many arguments");
255 /*--------------------------------------------------------------
256 | Prepare function args
257 --------------------------------------------------------------*/
260 fprintf( stderr, " [wine.xs/call_wine_API()]\n");
262 for (i = 0; (i < n_args); i++)
264 sv = ST (n_fixed + i);
270 /*--------------------------------------------------------------
272 --------------------------------------------------------------*/
277 /*--------------------------------------------------------------
278 | Integer ref -- pass address of value
279 --------------------------------------------------------------*/
282 args[i].ival = SvIV (sv);
283 f_args[i] = (unsigned long) &(args[i].ival);
286 fprintf( stderr, " [RV->IV] 0x%lx\n", f_args[i]);
290 /*--------------------------------------------------------------
291 | Number ref -- convert and pass address of value
292 --------------------------------------------------------------*/
295 args[i].ival = (unsigned long) SvNV (sv);
296 f_args[i] = (unsigned long) &(args[i].ival);
299 fprintf( stderr, " [RV->NV] 0x%lx\n", f_args[i]);
303 /*--------------------------------------------------------------
304 | String ref -- pass pointer
305 --------------------------------------------------------------*/
308 f_args[i] = (unsigned long) ((char *) SvPV (sv, PL_na));
311 fprintf( stderr, " [RV->PV] 0x%lx\n", f_args[i]);
316 /*--------------------------------------------------------------
318 --------------------------------------------------------------*/
322 /*--------------------------------------------------------------
323 | Integer -- pass value
324 --------------------------------------------------------------*/
327 f_args[i] = (unsigned long) SvIV (sv);
330 fprintf( stderr, " [IV] %ld (0x%lx)\n", f_args[i], f_args[i]);
334 /*--------------------------------------------------------------
335 | Number -- convert and pass value
336 --------------------------------------------------------------*/
339 f_args[i] = (unsigned long) SvNV (sv);
342 fprintf( stderr, " [NV] %ld (0x%lx)\n", f_args[i], f_args[i]);
346 /*--------------------------------------------------------------
347 | String -- pass pointer to copy
348 --------------------------------------------------------------*/
352 if ((args[i].pval = malloc( n+2 )))
354 memcpy (args[i].pval, p, n);
355 ((char *)(args[i].pval))[n] = 0; /* add final NULL */
356 ((char *)(args[i].pval))[n+1] = 0; /* and another one for Unicode too */
357 f_args[i] = (unsigned long) args[i].pval;
360 fprintf( stderr, " [PV] 0x%lx\n", f_args[i]);
368 /*--------------------------------------------------------------
370 --------------------------------------------------------------*/
371 r = perl_call_wine( (FARPROC)function, n_args, f_args, &last_error, debug );
373 /*--------------------------------------------------------------
374 | Handle modified parameter values
376 | There are four possibilities for parameter values:
380 | 3) ref to integer value
381 | 4) ref to string value
383 | In cases 1 and 2, the intent is that the values won't be
384 | modified, because they're not passed by ref. So we leave
387 | In case 4, the address of the actual string buffer has
388 | already been passed to the wine API function, which had
389 | opportunity to modify it if it wanted to. So again, we
390 | don't have anything to do here.
392 | The case we need to handle is case 3. For integers passed
393 | by ref, we created a local containing the initial value,
394 | and passed its address to the wine API function, which
395 | (potentially) modified it. Now we have to copy the
396 | (potentially) new value back to the Perl variable passed
397 | in, using sv_setiv(). (Which will take fewer lines of code
398 | to do than it took lines of comment to describe ...)
399 --------------------------------------------------------------*/
400 for (i = 0; (i < n_args); i++)
402 sv = ST (n_fixed + i);
405 if (SvROK (sv) && (sv = SvRV (sv)) && SvIOK (sv))
407 sv_setiv (sv, args[i].ival);
411 /*--------------------------------------------------------------
412 | Put appropriate return value on the stack for Perl to pick
414 --------------------------------------------------------------*/
416 if (last_error != 0xdeadbeef) PUSHs(sv_2mortal(newSViv(last_error)));
417 else PUSHs( &PL_sv_undef );
418 PUSHs (convert_value (ret_type, r));
420 /*--------------------------------------------------------------
421 | Free up allocated memory
422 --------------------------------------------------------------*/
423 for (i = 0; (i < n_args); i++)
425 if (args[i].pval) free(args[i].pval);
429 # --------------------------------------------------------------------
430 # Function: load_library
431 # --------------------------------------------------------------------
432 # Purpose: Load a Wine library
434 # Parameters: module -- module (dll) to load
436 # Returns: module handle
437 # --------------------------------------------------------------------
444 ST(0) = newSViv( (I32)LoadLibraryA(module) );
448 # --------------------------------------------------------------------
449 # Function: get_proc_address
450 # --------------------------------------------------------------------
451 # Purpose: Retrive a function address
453 # Parameters: module -- module handle
454 # --------------------------------------------------------------------
456 get_proc_address(module,func)
457 unsigned long module;
462 ST(0) = newSViv( (I32)GetProcAddress( (HMODULE)module, func ) );
466 # --------------------------------------------------------------------
467 # Function: alloc_thunk
468 # --------------------------------------------------------------------
469 # Purpose: Allocate a thunk for a wine API callback
471 # This is used when a Wine API function is called from Perl, and
472 # that API function takes a callback as one of its parameters.
474 # The Wine API function, of course, must be passed the address of
475 # a C function as the callback. But if the API is called from Perl,
476 # we want the user to be able to specify a Perl sub as the callback,
477 # and have control returned there each time the callback is called.
479 # This function takes a code ref to a Perl sub as one of its
480 # arguments. It then creates a unique C function (a thunk) on the
481 # fly, which can be passed to the Wine API function as its callback.
483 # The thunk has its own data area (as thunks are wont to do); one
484 # of the things stashed there is aforementioned Perl code ref. So
485 # the sequence of events is as follows:
487 # 1) From Perl, user calls alloc_callback(), passing a ref
488 # to a Perl sub to use as the callback.
490 # 2) alloc_callback() calls this routine. This routine
491 # creates a thunk, and stashes the above code ref in
492 # it. This function then returns a pointer to the thunk
495 # 3) From Perl, user calls Wine API function. As the parameter
496 # which is supposed to be the address of the callback, the
497 # user passes the pointer to the thunk allocated above.
499 # 4) The Wine API function gets called. It periodically calls
500 # the callback, which executes the thunk.
502 # 5) Each time the thunk is executed, it calls callback_bridge()
503 # (defined in winetest.c).
505 # 6) callback_bridge() fishes the Perl code ref out of the
506 # thunk data area and calls the Perl callback.
508 # Voila. The Perl callback gets called each time the Wine API
509 # function calls its callback.
511 # Parameters: [todo] Parameters ...
513 # Returns: Pointer to thunk
514 # --------------------------------------------------------------------
524 /* Allocate the thunk */
525 if (!(thunk = malloc( sizeof(*thunk) ))) croak( "Out of memory" );
527 (*thunk) = thunk_template;
528 thunk->args_ptr = thunk->arg_types;
529 thunk->nb_args = items - 1;
530 thunk->code_ref = SvRV (ST (0));
531 thunk->func = (void *)((char *) callback_bridge - (char *) &thunk->leave);
532 thunk->arg_size = thunk->nb_args * sizeof(int);
534 /* Stash callback arg types */
535 for (i = 1; i < items; i++) thunk->arg_types[i - 1] = SvIV (ST (i));
537 /*--------------------------------------------------------------
538 | Push the address of the thunk on the stack for return
540 | [todo] We need to free up the memory allocated somehow ...
541 --------------------------------------------------------------*/
542 ST (0) = newSViv ((I32) thunk);