# -------------------------------------------------------------------- # Module: wine.pm # # Purpose: Module to supply wrapper around and support for gateway to # Windows API functions # # Copyright 2001 John F Sturtz for Codeweavers # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # -------------------------------------------------------------------- package wine; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD $todo_level $successes $failures $todo_successes $todo_failures $winetest_report_success %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 = (); $winetest_report_success = defined($ENV{WINETEST_REPORT_SUCCESS}) ? $ENV{WINETEST_REPORT_SUCCESS} : 0; # -------------------------------------------------------------- # | 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 { print STDERR ("$filename:$line: Test succeeded\n") if ($winetest_report_success); $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