programs/winetest/wine.pm

   1 # --------------------------------------------------------------------------------
   2 # | Module:      wine.pm                                                         |
   3 # | ---------------------------------------------------------------------------- |
   4 # | Purpose:     Module to supply wrapper around and support for gateway to wine |
   5 # |              API functions                                                   |
   6 # --------------------------------------------------------------------------------
   7
   8 package wine;
   9
  10 use strict;
  11 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD
  12             %return_types %prototypes %loaded_modules);
  13
  14 require Exporter;
  15
  16 @ISA = qw(Exporter);
  17
  18 # Items to export into callers namespace by default. Note: do not export
  19 # names by default without a very good reason. Use EXPORT_OK instead.
  20 # Do not simply export all your public functions/methods/constants.
  21 @EXPORT = qw(
  22              AUTOLOAD
  23              alloc_callback
  24              assert
  25              hd
  26              wc
  27              wclen
  28             );
  29
  30 $VERSION = '0.01';
  31 bootstrap wine $VERSION;
  32
  33 # Global variables
  34 $wine::err = 0;
  35 $wine::debug = 0;
  36
  37 %loaded_modules = ();
  38
  39 # --------------------------------------------------------------
  40 # | Return-type constants                                      |
  41 # |                                                            |
  42 # | [todo]  I think there's a way to define these in a C       |
  43 # |         header file, so that both the C functions in the   |
  44 # |         XS module and the Perl routines in the .pm have    |
  45 # |         access to them.  But I haven't worked it out       |
  46 # |         yet ...                                            |
  47 # --------------------------------------------------------------
  48 %return_types = ( "void" => 0, "int" => 1, "word" => 2, "ptr" => 3 );
  49
  50
  51 # ------------------------------------------------------------------------
  52 # | Sub:       AUTOLOAD                                                  |
  53 # | -------------------------------------------------------------------- |
  54 # | Purpose:   Used to catch calls to undefined routines                 |
  55 # |                                                                      |
  56 # |     Any routine which is called and not defined is assumed to be     |
  57 # |     a call to the Wine API function of the same name.  We trans-     |
  58 # |     late it into a call to the call() subroutine, with FUNCTION      |
  59 # |     set to the function invoked and all other args passed thru.      |
  60 # ------------------------------------------------------------------------
  61 sub AUTOLOAD
  62 {
  63     # --------------------------------------------------------------
  64     # | Figure out who we are                                      |
  65     # --------------------------------------------------------------
  66     my ($pkg, $func) = (split /::/, $AUTOLOAD)[0,1];
  67
  68     # --------------------------------------------------------------
  69     # | Any function that is in the @EXPORT array is passed thru   |
  70     # | to AutoLoader to pick up the appropriate XS extension      |
  71     # --------------------------------------------------------------
  72     if (grep ($_ eq $func, @EXPORT))
  73     {
  74         $AutoLoader::AUTOLOAD = $AUTOLOAD;
  75         goto &AutoLoader::AUTOLOAD;
  76     }
  77
  78     # --------------------------------------------------------------
  79     # | Ignore this                                                |
  80     # --------------------------------------------------------------
  81     return
  82         if ($func eq 'DESTROY');
  83
  84     # --------------------------------------------------------------
  85     # | Otherwise, assume any undefined method is the name of a    |
  86     # | wine API call, and all the args are to be passed through   |
  87     # --------------------------------------------------------------
  88     if (defined($prototypes{$func}))
  89     {
  90         return call( $func, $wine::debug, @_ );
  91     }
  92     die "Function '$func' not declared";
  93 } # End AUTOLOAD
  94
  95
  96
  97 # ------------------------------------------------------------------------
  98 # | Sub:         call                                                    |
  99 # | -------------------------------------------------------------------- |
 100 # | Purpose:     Call a wine API function                                |
 101 # |                                                                      |
 102 # | Usage:       call FUNCTION, DEBUG, [ARGS ...]
 103 # |                                                                      |
 104 # | Returns:     value returned by API function called                   |
 105 # ------------------------------------------------------------------------
 106 sub call
 107 {
 108     my ($function,$debug,@args) = @_;
 109     my ($funcptr,$ret_type) = @{$prototypes{$function}};
 110
 111     if ($debug)
 112     {
 113         print STDERR "==== [$function() / " . scalar (@args) . " arg(s)]";
 114         for (@args)
 115         {
 116             print STDERR " ", +(ref () ? ("(" . ${$_} . ")") : "$_");
 117         }
 118         print STDERR " ====\n";
 119     }
 120
 121     # Now call call_wine_API(), which will turn around and call
 122     # the appropriate wine API function.
 123     my ($err,$r) = call_wine_API( $funcptr, $ret_type, $debug, @args );
 124
 125     if ($debug)
 126     {
 127         my $z = "[$function()] -> ";
 128         $z .= defined($r) ? sprintf("[0x%x/%d]", $r, $r) : "[void]";
 129         if (defined($err)) { $z .= sprintf " err=%d", $err; }
 130         print STDERR "==== $z ====\n";
 131     }
 132
 133     # Pass the return value back
 134     $wine::err = $err;
 135     return ($r);
 136 }
 137
 138
 139 # ----------------------------------------------------------------------
 140 # | Subroutine:  declare
 141 # ----------------------------------------------------------------------
 142 sub declare
 143 {
 144     my ($module, %list) = @_;
 145     my ($handle, $func);
 146
 147     if (defined($loaded_modules{$module}))
 148     {
 149         $handle = $loaded_modules{$module};
 150     }
 151     else
 152     {
 153         $handle = load_library($module) or die "Could not load '$module'";
 154         $loaded_modules{$module} = $handle;
 155     }
 156
 157     foreach $func (keys %list)
 158     {
 159         my $ptr = get_proc_address( $handle, $func ) or die "Could not find '$func' in '$module'";
 160         my $ret_type = $return_types{$list{$func}};
 161         $prototypes{$func} = [ $ptr, $ret_type ];
 162     }
 163 }
 164
 165
 166 # ------------------------------------------------------------------------
 167 # | Sub:         alloc_callback                                          |
 168 # | -------------------------------------------------------------------- |
 169 # | Purpose:     Allocate a thunk for a Wine API callback function.      |
 170 # |                                                                      |
 171 # |     Basically a thin wrapper over alloc_thunk(); see wine.xs for     |
 172 # |     details ...                                                      |
 173 # |                                                                      |
 174 # | Usage:       alloc_callback SUB_REF, [ ARGS_TYPES ... ]              |
 175 # |                                                                      |
 176 # | Returns:     Pointer to thunk allocated (as an integer value)        |
 177 # |                                                                      |
 178 # |     The returned value is just a raw pointer to a block of memory    |
 179 # |     allocated by the C code (cast into a Perl integer).  It isn't    |
 180 # |     really suitable for anything but to be passed to a wine API      |
 181 # |     function ...                                                     |
 182 # ------------------------------------------------------------------------
 183 sub alloc_callback
 184 {
 185     # ----------------------------------------------
 186     # | Locals                                     |
 187     # |                                            |
 188     # | [todo]  Check arg types                    |
 189     # ----------------------------------------------
 190     my  $sub_ref            = shift;
 191     my  @callback_arg_types = @_;
 192
 193     # [todo]  Check args
 194     # [todo]  Some way of specifying args passed to callback
 195
 196     # --------------------------------------------------------------
 197     # | Convert arg types to integers                              |
 198     # --------------------------------------------------------------
 199     map { $_ = $return_types{$_} } @callback_arg_types;
 200
 201     # --------------------------------------------------------------
 202     # | Pass thru to alloc_thunk()                                 |
 203     # --------------------------------------------------------------
 204     return alloc_thunk ($sub_ref, @callback_arg_types);
 205 }
 206
 207
 208 # ----------------------------------------------------------------------
 209 # | Subroutine:  hd                                                    |
 210 # |                                                                    |
 211 # | Purpose:     Display a hex dump of a string                        |
 212 # |                                                                    |
 213 # | Usage:       hd STR                                                |
 214 # | Usage:       hd STR, LENGTH                                        |
 215 # |                                                                    |
 216 # | Returns:     (none)                                                |
 217 # ----------------------------------------------------------------------
 218 sub hd
 219 {
 220     # Locals
 221     my  ($buf, $length);
 222     my  $first;
 223     my  ($str1, $str2, $str, $t);
 224     my  ($c, $x);
 225
 226 # Begin sub hd
 227
 228     # --------------------------------------------------------------
 229     # | Get args; if no BUF specified, blow                        |
 230     # --------------------------------------------------------------
 231     $buf = shift;
 232     $length = (shift or length ($buf));
 233     return
 234         if ((not defined ($buf)) || ($length <= 0));
 235
 236     # --------------------------------------------------------------
 237     # | Initialize                                                 |
 238     # --------------------------------------------------------------
 239     $first = 1;
 240     $str1 = "00000:";
 241     $str2 = "";
 242
 243     # --------------------------------------------------------------
 244     # | For each character                                         |
 245     # --------------------------------------------------------------
 246     for (0 .. ($length - 1))
 247     {
 248         $c = substr ($buf, $_, 1);
 249         $x = sprintf ("%02x", ord ($c));
 250         $str1 .= (" " . $x);
 251         $str2 .= (((ord ($c) >= 33) && (ord ($c) <= 126)) ? $c : ".");
 252
 253         # --------------------------------------------------------------
 254         # | Every group of 4, add an extra space                       |
 255         # --------------------------------------------------------------
 256         if
 257         (
 258             ((($_ + 1) % 16) == 4)  ||
 259             ((($_ + 1) % 16) == 12)
 260         )
 261         {
 262             $str1 .= " ";
 263             $str2 .= " ";
 264         }
 265
 266         # --------------------------------------------------------------
 267         # | Every group of 8, add a '-'                                |
 268         # --------------------------------------------------------------
 269         elsif
 270         (
 271             ((($_ + 1) % 16) == 8)
 272         )
 273         {
 274             $str1 .= " -";
 275             $str2 .= " ";
 276         }
 277
 278         # --------------------------------------------------------------
 279         # | Every group of 16, dump                                    |
 280         # --------------------------------------------------------------
 281         if
 282         (
 283             ((($_ + 1) % 16) == 0)      ||
 284             ($_ == ($length - 1))
 285         )
 286         {
 287             $str = sprintf ("%-64s%s", $str1, $str2);
 288             if ($first)
 289             {
 290                 $t = ("-" x length ($str));
 291                 print "  $t\n";
 292                 print "  | $length bytes\n";
 293                 print "  $t\n";
 294                 $first = 0;
 295             }
 296             print "  $str\n";
 297             $str1 = sprintf ("%05d:", ($_ + 1));
 298             $str2 = "";
 299             if ($_ == ($length - 1))
 300             {
 301                 print "  $t\n";
 302             }
 303         }
 304
 305     }  # end for
 306
 307
 308     # --------------------------------------------------------------
 309     # | Exit point                                                 |
 310     # --------------------------------------------------------------
 311     return;
 312
 313 } # End sub hd
 314
 315
 316
 317 # ----------------------------------------------------------------------
 318 # | Subroutine:  wc                                                    |
 319 # |                                                                    |
 320 # | Purpose:     Generate unicode string                               |
 321 # |                                                                    |
 322 # | Usage:       wc ASCII_STRING                                       |
 323 # |                                                                    |
 324 # | Returns:     string generated                                      |
 325 # ----------------------------------------------------------------------
 326 sub wc
 327 {
 328     return pack("S*",unpack("C*",shift));
 329 } # End sub wc
 330
 331
 332
 333 # ----------------------------------------------------------------------
 334 # | Subroutine:  wclen                                                 |
 335 # |                                                                    |
 336 # | Purpose:     Return length of unicode string                       |
 337 # |                                                                    |
 338 # | Usage:       wclen UNICODE_STRING                                  |
 339 # |                                                                    |
 340 # | Returns:     string generated                                      |
 341 # ----------------------------------------------------------------------
 342 sub wclen
 343 {
 344     # Locals
 345     my  $str = shift;
 346     my  ($c1, $c2, $n);
 347
 348 # Begin sub wclen
 349
 350     $n = 0;
 351     while (length ($str) > 0)
 352     {
 353         $c1 = substr ($str, 0, 1, "");
 354         $c2 = substr ($str, 0, 1, "");
 355         (($c1 eq "\x00") && ($c2 eq "\x00")) ? last : $n++;
 356     }
 357
 358     return ($n);
 359
 360 } # End sub wclen
 361
 362
 363
 364 # ----------------------------------------------------------------------
 365 # | Subroutine:  assert                                                |
 366 # |                                                                    |
 367 # | Purpose:     Print warning if something fails                      |
 368 # |                                                                    |
 369 # | Usage:       assert CONDITION                                      |
 370 # |                                                                    |
 371 # | Returns:     (none)                                                |
 372 # ----------------------------------------------------------------------
 373 sub assert
 374 {
 375     # Locals
 376     my  $assertion = shift;
 377     my  ($fn, $line);
 378
 379 # Begin sub assert
 380
 381     ($fn, $line) = (caller (0))[1,2];
 382     unless ($assertion) { print "Assertion failed [$fn, line $line]\n"; exit 1; }
 383
 384 } # End sub assert
 385
 386
 387 # Autoload methods go after =cut, and are processed by the autosplit program.
 388 1;
 389 __END__
 390
 391
 392
 393 # ------------------------------------------------------------------------
 394 # | pod documentation                                                    |
 395 # |                                                                      |
 396 # |                                                                      |
 397 # ------------------------------------------------------------------------
 398
 399 =head1 NAME
 400
 401 wine - Perl extension for calling wine API functions
 402
 403 =head1 SYNOPSIS
 404
 405     use wine;
 406
 407     wine::declare( "kernel32",
 408                    SetLastError => "void",
 409                    GetLastError => "int" );
 410     SetLastError( 1234 );
 411     printf "%d\n", GetLastError();
 412
 413
 414 =head1 DESCRIPTION
 415
 416 This module provides a gateway for calling Win32 API functions from
 417 a Perl script.
 418
 419 =head1 CALLING WIN32 API FUNCTIONS
 420
 421 The functions you want to call must first be declared by calling
 422 the wine::declare method. The first argument is the name of the
 423 module containing the APIs, and the next argument is a list of
 424 function names and their return types. For instance:
 425
 426     wine::declare( "kernel32",
 427                    SetLastError => "void",
 428                    GetLastError => "int" );
 429
 430 declares that the functions SetLastError and GetLastError are
 431 contained in the kernel32 dll.
 432
 433 Once you have done that you can call the functions directly just
 434 like native Perl functions:
 435
 436   SetLastError( $some_error );
 437
 438 The supported return types are:
 439
 440 =over 4
 441
 442 =item void
 443
 444 =item word
 445
 446 =item int
 447
 448 =item ptr
 449
 450 =back
 451
 452 =head1 $wine::err VARIABLE
 453
 454 In the Win32 API, an integer error code is maintained which always
 455 contains the status of the last API function called.  In C code,
 456 it is accessed via the GetLastError() function.  From a Perl script,
 457 it can be accessed via the package global $wine::err.  For example:
 458
 459     GlobalGetAtomNameA ($atom, \$buf, -1);
 460     if ($wine::err == 234)
 461     {
 462         ...
 463     }
 464
 465 Wine returns 234 (ERROR_MORE_DATA) from the GlobalGetAtomNameA()
 466 API function in this case because the buffer length passed is -1
 467 (hardly enough room to store anything in ...)
 468
 469 If the called API didn't set the last error code, $wine:;err is
 470 undefined.
 471
 472 =head1 $wine::debug VARIABLE
 473
 474 This variable can be set to 1 to enable debugging of the API calls,
 475 which will print a lot of information about what's going on inside the
 476 wine package while calling an API function.
 477
 478 =head1 OTHER USEFUL FUNCTIONS
 479
 480 The bundle that includes the wine extension also includes a module of
 481 plain ol' Perl subroutines which are useful for interacting with wine
 482 API functions. Currently supported functions are:
 483
 484 =over 4
 485
 486 =item hd BUF [, LENGTH]
 487
 488 Dump a formatted hex dump to STDOUT.  BUF is a string containing
 489 the buffer to dump; LENGTH is the length to dump (length (BUF) if
 490 omitted).  This is handy because wine often writes a null character
 491 into the middle of a buffer, thinking that the next piece of code to
 492 look at the buffer will be a piece of C code that will regard it as
 493 a string terminator.  Little does it know that the buffer is going
 494 to be returned to a Perl script, which may not ...
 495
 496 =item wc STR
 497
 498 Generate and return a wide-character (Unicode) string from the given
 499 ASCII string
 500
 501 =item wclen WSTR
 502
 503 Return the length of the given wide-character string
 504
 505 =item assert CONDITION
 506
 507 Print a message if the assertion fails (i.e., CONDITION is false),
 508 or do nothing quietly if it is true.  The message includes the script
 509 name and line number of the assertion that failed.
 510
 511 =back
 512
 513
 514
 515 =head1 AUTHOR
 516
 517 John F Sturtz, jsturtz@codeweavers.com
 518
 519 =head1 SEE ALSO
 520
 521 wine documentation
 522
 523 =cut