| # -------------------------------------------------------------------------------- | |
| # | Module: wine.pm | | |
| # | ---------------------------------------------------------------------------- | | |
| # | Purpose: Module to supply wrapper around and support for gateway to wine | | |
| # | API functions | | |
| # -------------------------------------------------------------------------------- | |
| package wine; | |
| use strict; | |
| use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD | |
| %return_types %prototypes %loaded_modules); | |
| require Exporter; | |
| @ISA = qw(Exporter); | |
| # Items to export into callers namespace by default. Note: do not export | |
| # names by default without a very good reason. Use EXPORT_OK instead. | |
| # Do not simply export all your public functions/methods/constants. | |
| @EXPORT = qw( | |
| AUTOLOAD | |
| alloc_callback | |
| assert | |
| hd | |
| wc | |
| wclen | |
| ); | |
| $VERSION = '0.01'; | |
| bootstrap wine $VERSION; | |
| # Global variables | |
| $wine::err = 0; | |
| $wine::debug = 0; | |
| %loaded_modules = (); | |
| # -------------------------------------------------------------- | |
| # | Return-type constants | | |
| # | | | |
| # | [todo] I think there's a way to define these in a C | | |
| # | header file, so that both the C functions in the | | |
| # | XS module and the Perl routines in the .pm have | | |
| # | access to them. But I haven't worked it out | | |
| # | yet ... | | |
| # -------------------------------------------------------------- | |
| %return_types = ( "void" => 0, "int" => 1, "word" => 2, "ptr" => 3 ); | |
| # ------------------------------------------------------------------------ | |
| # | Sub: AUTOLOAD | | |
| # | -------------------------------------------------------------------- | | |
| # | Purpose: Used to catch calls to undefined routines | | |
| # | | | |
| # | Any routine which is called and not defined is assumed to be | | |
| # | a call to the Wine API function of the same name. We trans- | | |
| # | late it into a call to the call() subroutine, with FUNCTION | | |
| # | set to the function invoked and all other args passed thru. | | |
| # ------------------------------------------------------------------------ | |
| sub AUTOLOAD | |
| { | |
| # -------------------------------------------------------------- | |
| # | Figure out who we are | | |
| # -------------------------------------------------------------- | |
| my ($pkg, $func) = (split /::/, $AUTOLOAD)[0,1]; | |
| # -------------------------------------------------------------- | |
| # | Any function that is in the @EXPORT array is passed thru | | |
| # | to AutoLoader to pick up the appropriate XS extension | | |
| # -------------------------------------------------------------- | |
| if (grep ($_ eq $func, @EXPORT)) | |
| { | |
| $AutoLoader::AUTOLOAD = $AUTOLOAD; | |
| goto &AutoLoader::AUTOLOAD; | |
| } | |
| # -------------------------------------------------------------- | |
| # | Ignore this | | |
| # -------------------------------------------------------------- | |
| return | |
| if ($func eq 'DESTROY'); | |
| # -------------------------------------------------------------- | |
| # | Otherwise, assume any undefined method is the name of a | | |
| # | wine API call, and all the args are to be passed through | | |
| # -------------------------------------------------------------- | |
| if (defined($prototypes{$func})) | |
| { | |
| return call( $func, $wine::debug, @_ ); | |
| } | |
| die "Function '$func' not declared"; | |
| } # End AUTOLOAD | |
| # ------------------------------------------------------------------------ | |
| # | Sub: call | | |
| # | -------------------------------------------------------------------- | | |
| # | Purpose: Call a wine API function | | |
| # | | | |
| # | Usage: call FUNCTION, DEBUG, [ARGS ...] | |
| # | | | |
| # | Returns: value returned by API function called | | |
| # ------------------------------------------------------------------------ | |
| sub call | |
| { | |
| my ($function,$debug,@args) = @_; | |
| my ($funcptr,$ret_type) = @{$prototypes{$function}}; | |
| if ($debug) | |
| { | |
| print STDERR "==== [$function() / " . scalar (@args) . " arg(s)]"; | |
| for (@args) | |
| { | |
| print STDERR " ", +(ref () ? ("(" . ${$_} . ")") : "$_"); | |
| } | |
| print STDERR " ====\n"; | |
| } | |
| # Now call call_wine_API(), which will turn around and call | |
| # the appropriate wine API function. | |
| my ($err,$r) = call_wine_API( $funcptr, $ret_type, $debug, @args ); | |
| if ($debug) | |
| { | |
| my $z = "[$function()] -> "; | |
| $z .= defined($r) ? sprintf("[0x%x/%d]", $r, $r) : "[void]"; | |
| if (defined($err)) { $z .= sprintf " err=%d", $err; } | |
| print STDERR "==== $z ====\n"; | |
| } | |
| # Pass the return value back | |
| $wine::err = $err; | |
| return ($r); | |
| } | |
| # ---------------------------------------------------------------------- | |
| # | Subroutine: declare | |
| # ---------------------------------------------------------------------- | |
| sub declare | |
| { | |
| my ($module, %list) = @_; | |
| my ($handle, $func); | |
| if (defined($loaded_modules{$module})) | |
| { | |
| $handle = $loaded_modules{$module}; | |
| } | |
| else | |
| { | |
| $handle = load_library($module) or die "Could not load '$module'"; | |
| $loaded_modules{$module} = $handle; | |
| } | |
| foreach $func (keys %list) | |
| { | |
| my $ptr = get_proc_address( $handle, $func ) or die "Could not find '$func' in '$module'"; | |
| my $ret_type = $return_types{$list{$func}}; | |
| $prototypes{$func} = [ $ptr, $ret_type ]; | |
| } | |
| } | |
| # ------------------------------------------------------------------------ | |
| # | Sub: alloc_callback | | |
| # | -------------------------------------------------------------------- | | |
| # | Purpose: Allocate a thunk for a Wine API callback function. | | |
| # | | | |
| # | Basically a thin wrapper over alloc_thunk(); see wine.xs for | | |
| # | details ... | | |
| # | | | |
| # | Usage: alloc_callback SUB_REF, [ ARGS_TYPES ... ] | | |
| # | | | |
| # | Returns: Pointer to thunk allocated (as an integer value) | | |
| # | | | |
| # | The returned value is just a raw pointer to a block of memory | | |
| # | allocated by the C code (cast into a Perl integer). It isn't | | |
| # | really suitable for anything but to be passed to a wine API | | |
| # | function ... | | |
| # ------------------------------------------------------------------------ | |
| sub alloc_callback | |
| { | |
| # ---------------------------------------------- | |
| # | Locals | | |
| # | | | |
| # | [todo] Check arg types | | |
| # ---------------------------------------------- | |
| my $sub_ref = shift; | |
| my @callback_arg_types = @_; | |
| # [todo] Check args | |
| # [todo] Some way of specifying args passed to callback | |
| # -------------------------------------------------------------- | |
| # | Convert arg types to integers | | |
| # -------------------------------------------------------------- | |
| map { $_ = $return_types{$_} } @callback_arg_types; | |
| # -------------------------------------------------------------- | |
| # | Pass thru to alloc_thunk() | | |
| # -------------------------------------------------------------- | |
| return alloc_thunk ($sub_ref, @callback_arg_types); | |
| } | |
| # ---------------------------------------------------------------------- | |
| # | Subroutine: hd | | |
| # | | | |
| # | Purpose: Display a hex dump of a string | | |
| # | | | |
| # | Usage: hd STR | | |
| # | Usage: hd STR, LENGTH | | |
| # | | | |
| # | Returns: (none) | | |
| # ---------------------------------------------------------------------- | |
| sub hd | |
| { | |
| # Locals | |
| my ($buf, $length); | |
| my $first; | |
| my ($str1, $str2, $str, $t); | |
| my ($c, $x); | |
| # Begin sub hd | |
| # -------------------------------------------------------------- | |
| # | Get args; if no BUF specified, blow | | |
| # -------------------------------------------------------------- | |
| $buf = shift; | |
| $length = (shift or length ($buf)); | |
| return | |
| if ((not defined ($buf)) || ($length <= 0)); | |
| # -------------------------------------------------------------- | |
| # | Initialize | | |
| # -------------------------------------------------------------- | |
| $first = 1; | |
| $str1 = "00000:"; | |
| $str2 = ""; | |
| # -------------------------------------------------------------- | |
| # | For each character | | |
| # -------------------------------------------------------------- | |
| for (0 .. ($length - 1)) | |
| { | |
| $c = substr ($buf, $_, 1); | |
| $x = sprintf ("%02x", ord ($c)); | |
| $str1 .= (" " . $x); | |
| $str2 .= (((ord ($c) >= 33) && (ord ($c) <= 126)) ? $c : "."); | |
| # -------------------------------------------------------------- | |
| # | Every group of 4, add an extra space | | |
| # -------------------------------------------------------------- | |
| if | |
| ( | |
| ((($_ + 1) % 16) == 4) || | |
| ((($_ + 1) % 16) == 12) | |
| ) | |
| { | |
| $str1 .= " "; | |
| $str2 .= " "; | |
| } | |
| # -------------------------------------------------------------- | |
| # | Every group of 8, add a '-' | | |
| # -------------------------------------------------------------- | |
| elsif | |
| ( | |
| ((($_ + 1) % 16) == 8) | |
| ) | |
| { | |
| $str1 .= " -"; | |
| $str2 .= " "; | |
| } | |
| # -------------------------------------------------------------- | |
| # | Every group of 16, dump | | |
| # -------------------------------------------------------------- | |
| if | |
| ( | |
| ((($_ + 1) % 16) == 0) || | |
| ($_ == ($length - 1)) | |
| ) | |
| { | |
| $str = sprintf ("%-64s%s", $str1, $str2); | |
| if ($first) | |
| { | |
| $t = ("-" x length ($str)); | |
| print " $t\n"; | |
| print " | $length bytes\n"; | |
| print " $t\n"; | |
| $first = 0; | |
| } | |
| print " $str\n"; | |
| $str1 = sprintf ("%05d:", ($_ + 1)); | |
| $str2 = ""; | |
| if ($_ == ($length - 1)) | |
| { | |
| print " $t\n"; | |
| } | |
| } | |
| } # end for | |
| # -------------------------------------------------------------- | |
| # | Exit point | | |
| # -------------------------------------------------------------- | |
| return; | |
| } # End sub hd | |
| # ---------------------------------------------------------------------- | |
| # | Subroutine: wc | | |
| # | | | |
| # | Purpose: Generate unicode string | | |
| # | | | |
| # | Usage: wc ASCII_STRING | | |
| # | | | |
| # | Returns: string generated | | |
| # ---------------------------------------------------------------------- | |
| sub wc | |
| { | |
| return pack("S*",unpack("C*",shift)); | |
| } # End sub wc | |
| # ---------------------------------------------------------------------- | |
| # | Subroutine: wclen | | |
| # | | | |
| # | Purpose: Return length of unicode string | | |
| # | | | |
| # | Usage: wclen UNICODE_STRING | | |
| # | | | |
| # | Returns: string generated | | |
| # ---------------------------------------------------------------------- | |
| sub wclen | |
| { | |
| # Locals | |
| my $str = shift; | |
| my ($c1, $c2, $n); | |
| # Begin sub wclen | |
| $n = 0; | |
| while (length ($str) > 0) | |
| { | |
| $c1 = substr ($str, 0, 1, ""); | |
| $c2 = substr ($str, 0, 1, ""); | |
| (($c1 eq "\x00") && ($c2 eq "\x00")) ? last : $n++; | |
| } | |
| return ($n); | |
| } # End sub wclen | |
| # ---------------------------------------------------------------------- | |
| # | Subroutine: assert | | |
| # | | | |
| # | Purpose: Print warning if something fails | | |
| # | | | |
| # | Usage: assert CONDITION | | |
| # | | | |
| # | Returns: (none) | | |
| # ---------------------------------------------------------------------- | |
| sub assert | |
| { | |
| # Locals | |
| my $assertion = shift; | |
| my ($fn, $line); | |
| # Begin sub assert | |
| ($fn, $line) = (caller (0))[1,2]; | |
| unless ($assertion) { print "Assertion failed [$fn, line $line]\n"; exit 1; } | |
| } # End sub assert | |
| # Autoload methods go after =cut, and are processed by the autosplit program. | |
| 1; | |
| __END__ | |
| # ------------------------------------------------------------------------ | |
| # | pod documentation | | |
| # | | | |
| # | | | |
| # ------------------------------------------------------------------------ | |
| =head1 NAME | |
| wine - Perl extension for calling wine API functions | |
| =head1 SYNOPSIS | |
| use wine; | |
| wine::declare( "kernel32", | |
| SetLastError => "void", | |
| GetLastError => "int" ); | |
| SetLastError( 1234 ); | |
| printf "%d\n", GetLastError(); | |
| =head1 DESCRIPTION | |
| This module provides a gateway for calling Win32 API functions from | |
| a Perl script. | |
| =head1 CALLING WIN32 API FUNCTIONS | |
| The functions you want to call must first be declared by calling | |
| the wine::declare method. The first argument is the name of the | |
| module containing the APIs, and the next argument is a list of | |
| function names and their return types. For instance: | |
| wine::declare( "kernel32", | |
| SetLastError => "void", | |
| GetLastError => "int" ); | |
| declares that the functions SetLastError and GetLastError are | |
| contained in the kernel32 dll. | |
| Once you have done that you can call the functions directly just | |
| like native Perl functions: | |
| SetLastError( $some_error ); | |
| The supported return types are: | |
| =over 4 | |
| =item void | |
| =item word | |
| =item int | |
| =item ptr | |
| =back | |
| =head1 $wine::err VARIABLE | |
| In the Win32 API, an integer error code is maintained which always | |
| contains the status of the last API function called. In C code, | |
| it is accessed via the GetLastError() function. From a Perl script, | |
| it can be accessed via the package global $wine::err. For example: | |
| GlobalGetAtomNameA ($atom, \$buf, -1); | |
| if ($wine::err == 234) | |
| { | |
| ... | |
| } | |
| Wine returns 234 (ERROR_MORE_DATA) from the GlobalGetAtomNameA() | |
| API function in this case because the buffer length passed is -1 | |
| (hardly enough room to store anything in ...) | |
| If the called API didn't set the last error code, $wine:;err is | |
| undefined. | |
| =head1 $wine::debug VARIABLE | |
| This variable can be set to 1 to enable debugging of the API calls, | |
| which will print a lot of information about what's going on inside the | |
| wine package while calling an API function. | |
| =head1 OTHER USEFUL FUNCTIONS | |
| The bundle that includes the wine extension also includes a module of | |
| plain ol' Perl subroutines which are useful for interacting with wine | |
| API functions. Currently supported functions are: | |
| =over 4 | |
| =item hd BUF [, LENGTH] | |
| Dump a formatted hex dump to STDOUT. BUF is a string containing | |
| the buffer to dump; LENGTH is the length to dump (length (BUF) if | |
| omitted). This is handy because wine often writes a null character | |
| into the middle of a buffer, thinking that the next piece of code to | |
| look at the buffer will be a piece of C code that will regard it as | |
| a string terminator. Little does it know that the buffer is going | |
| to be returned to a Perl script, which may not ... | |
| =item wc STR | |
| Generate and return a wide-character (Unicode) string from the given | |
| ASCII string | |
| =item wclen WSTR | |
| Return the length of the given wide-character string | |
| =item assert CONDITION | |
| Print a message if the assertion fails (i.e., CONDITION is false), | |
| or do nothing quietly if it is true. The message includes the script | |
| name and line number of the assertion that failed. | |
| =back | |
| =head1 AUTHOR | |
| John F Sturtz, jsturtz@codeweavers.com | |
| =head1 SEE ALSO | |
| wine documentation | |
| =cut |