| # -------------------------------------------------------------------- | |
| # Module: wine.pm | |
| # | |
| # Purpose: Module to supply wrapper around and support for gateway to | |
| # Windows API functions | |
| # -------------------------------------------------------------------- | |
| package wine; | |
| use strict; | |
| use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD $todo_level | |
| $successes $failures $todo_successes $todo_failures | |
| %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 | |
| ok | |
| todo | |
| todo_wine | |
| trace | |
| wc | |
| wclen | |
| ); | |
| $VERSION = '0.01'; | |
| bootstrap wine $VERSION; | |
| # Global variables | |
| $wine::err = 0; | |
| $wine::exit_status = 0; | |
| $wine::debug = defined($ENV{WINETEST_DEBUG}) ? $ENV{WINETEST_DEBUG} : 1; | |
| $wine::platform = defined($ENV{WINETEST_PLATFORM}) ? $ENV{WINETEST_PLATFORM} : "windows"; | |
| $todo_level = 0; | |
| $successes = 0; | |
| $failures = 0; | |
| $todo_successes = 0; | |
| $todo_failures = 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, "long" => 1, | |
| "word" => 2, | |
| "ptr" => 3, | |
| "str" => 4, "wstr" => 4 | |
| ); | |
| # ------------------------------------------------------------------------ | |
| # | 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, @_ ); | |
| } | |
| die "Function '$func' not declared"; | |
| } # End AUTOLOAD | |
| # ------------------------------------------------------------------------ | |
| # | Sub: call | | |
| # | -------------------------------------------------------------------- | | |
| # | Purpose: Call a wine API function | | |
| # | | | |
| # | Usage: call FUNCTION, [ARGS ...] | |
| # | | | |
| # | Returns: value returned by API function called | | |
| # ------------------------------------------------------------------------ | |
| sub call($@) | |
| { | |
| my ($function,@args) = @_; | |
| my ($module,$funcptr,$ret_type,$arg_types) = @{$prototypes{$function}}; | |
| unless ($funcptr) | |
| { | |
| my $handle = $loaded_modules{$module}; | |
| $funcptr = get_proc_address( $handle, $function ) or die "Could not get address for $module.$function"; | |
| ${$prototypes{$function}}[1] = $funcptr; | |
| } | |
| if ($wine::debug > 1) | |
| { | |
| print STDERR "==== Call $function("; | |
| for (@args) | |
| { | |
| print STDERR " ", +(ref () ? ("(" . ${$_} . ")") : "$_"); | |
| } | |
| print STDERR " " if (scalar @args); | |
| print STDERR ")\n"; | |
| } | |
| # Check and translate args before call | |
| my @args2; | |
| if (defined($arg_types)) { | |
| my @arg_types = @$arg_types; | |
| if($#args != $#arg_types) { | |
| die "$function: Wrong number of arguments, expected " . | |
| ($#arg_types + 1) . ", got " . ($#args + 1) . "\n"; | |
| } | |
| while (defined(my $arg = shift @args) && | |
| defined(my $arg_type = shift @arg_types)) | |
| { | |
| if($arg_type == 1 || $arg_type == 2) { # int || word | |
| $arg = int($arg); | |
| } | |
| push @args2, $arg; | |
| } | |
| } else { | |
| @args2 = @args; | |
| } | |
| # 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, $wine::debug-1, @args2 ); | |
| if ($wine::debug > 1) | |
| { | |
| print STDERR "==== Ret $function()"; | |
| if (defined($r)) { printf STDERR " ret=0x%x", $r; } | |
| if (defined($err)) { printf STDERR " err=%d", $err; } | |
| print STDERR "\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) | |
| { | |
| if(ref($list{$func}) eq "ARRAY") { | |
| my ($return_type, $argument_types) = @{$list{$func}}; | |
| my $ret_type = $return_types{$return_type}; | |
| my $arg_types = [map { $return_types{$_} } @$argument_types]; | |
| $prototypes{$func} = [ $module, 0, $ret_type, $arg_types ]; | |
| } else { | |
| my $ret_type = $return_types{$list{$func}}; | |
| $prototypes{$func} = [ $module, 0, $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: ok | |
| # | |
| # Purpose: Print warning if something fails | |
| # | |
| # Usage: ok CONDITION [DESCRIPTION] | |
| # | |
| # Returns: (none) | |
| # ---------------------------------------------------------------------- | |
| sub ok($;$) | |
| { | |
| my $assertion = shift; | |
| my $description = shift; | |
| my ($filename, $line) = (caller (0))[1,2]; | |
| if ($todo_level) | |
| { | |
| if ($assertion) | |
| { | |
| print STDERR ("$filename:$line: Test succeeded inside todo block" . | |
| ($description ? ": $description" : "") . "\n"); | |
| $todo_failures++; | |
| } | |
| else { $todo_successes++; } | |
| } | |
| else | |
| { | |
| if (!$assertion) | |
| { | |
| print STDERR ("$filename:$line: Test failed" . | |
| ($description ? ": $description" : "") . "\n"); | |
| $failures++; | |
| } | |
| else { $successes++; } | |
| } | |
| } | |
| # ---------------------------------------------------------------------- | |
| # Subroutine: assert | |
| # | |
| # Purpose: Print error and die if something fails | |
| # | |
| # Usage: assert CONDITION [DESCRIPTION] | |
| # | |
| # Returns: (none) | |
| # ---------------------------------------------------------------------- | |
| sub assert($;$) | |
| { | |
| my $assertion = shift; | |
| my $description = shift; | |
| my ($filename, $line) = (caller (0))[1,2]; | |
| unless ($assertion) | |
| { | |
| die ("$filename:$line: Assertion failed" . ($description ? ": $description" : "") . "\n"); | |
| } | |
| } | |
| # ---------------------------------------------------------------------- | |
| # Subroutine: trace | |
| # | |
| # Purpose: Print debugging traces | |
| # | |
| # Usage: trace format [arguments] | |
| # ---------------------------------------------------------------------- | |
| sub trace($@) | |
| { | |
| return unless ($wine::debug > 0); | |
| my $format = shift; | |
| my $filename = (caller(0))[1]; | |
| $filename =~ s!.*/!!; | |
| printf "trace:$filename $format", @_; | |
| } | |
| # ---------------------------------------------------------------------- | |
| # Subroutine: todo | |
| # | |
| # Purpose: Specify a block of code as todo for a given platform | |
| # | |
| # Usage: todo name coderef | |
| # ---------------------------------------------------------------------- | |
| sub todo($$) | |
| { | |
| my ($platform,$code) = @_; | |
| if ($wine::platform eq $platform) | |
| { | |
| $todo_level++; | |
| eval &$code; | |
| $todo_level--; | |
| } | |
| else | |
| { | |
| eval &$code; | |
| } | |
| } | |
| # ---------------------------------------------------------------------- | |
| # Subroutine: todo_wine | |
| # | |
| # Purpose: Specify a block of test as todo for the Wine platform | |
| # | |
| # Usage: todo_wine { code } | |
| # ---------------------------------------------------------------------- | |
| sub todo_wine(&) | |
| { | |
| my $code = shift; | |
| todo( "wine", $code ); | |
| } | |
| # ---------------------------------------------------------------------- | |
| # Subroutine: END | |
| # | |
| # Purpose: Called at the end of execution, print results summary | |
| # ---------------------------------------------------------------------- | |
| END | |
| { | |
| return if $?; # got some other error already | |
| if ($wine::debug > 0) | |
| { | |
| my $filename = (caller(0))[1]; | |
| printf STDERR ("%s: %d tests executed, %d marked as todo, %d %s.\n", | |
| $filename, $successes + $failures + $todo_successes + $todo_failures, | |
| $todo_successes, $failures + $todo_failures, | |
| ($failures + $todo_failures != 1) ? "failures" : "failure" ); | |
| } | |
| $? = ($failures + $todo_failures < 255) ? $failures + $todo_failures : 255; | |
| } | |
| # 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", ["int"]], | |
| 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 and argument types. For instance: | |
| wine::declare( "kernel32", | |
| SetLastError => ["void", ["int"]], | |
| 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 long | |
| =item ptr | |
| =item str | |
| =item wstr | |
| =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 |