programs/winetest/wine.xs

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