Sweden-Number/programs/winetest/include/wine.pm

# --------------------------------------------------------------------
# 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, "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, @_ );
    }
    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 ($funcptr,$ret_type) = @{$prototypes{$function}};

    if ($wine::debug > 1)
    {
        print STDERR "==== Call $function(";
        for (@args)
        {
            print STDERR " ", +(ref () ? ("(" . ${$_} . ")") : "$_");
        }
        print STDERR " " if (scalar @args);
        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, $wine::debug-1, @args );

    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)
    {
        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:  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",
                   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