##!perl -w

# $Id: test.t,v 1.0 2001/10/30 13:57:31 dada Exp $

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

use strict;
use Config;
use Test::More;
use Math::Int64 qw( int64 hex_to_uint64 uint64_to_hex);
plan tests => 20;
use vars qw(
    $function
    $result
    $callback
    $test_dll
);

BEGIN {
    eval "sub PTR_SIZE () { ".length(pack(($] <= 5.007002 ? 'L':'J'),0))." }";
}
use_ok('Win32::API');
use_ok('Win32::API::Callback');
use Win32::API::Test;


ok(1, 'loaded');

$test_dll = Win32::API::Test::find_test_dll();
ok(-e $test_dll, 'found API_Test.dll');

my $cc_name = Win32::API::Test::compiler_name();
my $cc_vers = Win32::API::Test::compiler_version();
my $callback;

diag('Compiler name:',    $cc_name);
diag('Compiler version:', $cc_vers);

    $callback = Win32::API::Callback->new(
        sub {
            my ($value) = @_;
            die 'incorrect @_ count to the Perl Callback' if @_ != 1;
            return $value * 2;
        },
        'N',
        'N'
    );
    ok($callback, 'callback function defined');

    $function = new Win32::API($test_dll, 'do_callback', 'KI', 'I');
    ok(defined($function), 'defined function do_callback()');
    diag('$^E=', $^E);


    $result = $function->Call($callback, 21);
    is($result, 42, 'callback function works');

$callback = Win32::API::Callback->new(
    sub {
        #print Dumper(\@_);
        #$DB::single = 1;
        die 'incorrect @_ count to the Perl Callback' if @_ != 5;
        my $chr = $_[0];
        $chr = $_[0] & 0xFF; #x64 fill high bits with garbage
        die "bad char" if chr($chr) ne 'P';
        if(PTR_SIZE == 4){
            my ($low,$high) = unpack(IV_LET.IV_LET, $_[1]);
            die "bad unsigned int64" if $low != 0xABCDEF12;
            die "bad unsigned int64" if $high != 0x12345678;
        }else{
            print "0x".unpack('H[16]', $_[1])."\n";
            no warnings 'portable', 'overflow'; #silence on 32 bits
            die "bad unsigned int64" if $_[1] != eval "0x12345678ABCDEF12";
        }
        my $f4char = unpack('P4',pack(IV_LET,$_[2]));
        die "bad 4 char struct \"$f4char\"" if $f4char ne "JAPH";
        die "bad float" if $_[3] != 2.5;
        die "bad double" if $_[4] != 3.5;
        return 70000;
    },
    'I'. #the char
    'Q'. #the int 64
    'N'. #the pointer to 4 char struct
    'F'. #the float
    'D', #the double
    'N' #out type
);

$function = new Win32::API($test_dll, 'do_callback_5_param', 'K', 'N');
$result = $function->Call($callback);
is($result, 70000, "do_callback_5_param was successful");

SKIP: {
    skip('only 32 bit Perl uses Math::Int64', 5) if PTR_SIZE != 4;
    $callback = Win32::API::Callback->new(
        sub {
            #print Dumper(\@_);
            #$DB::single = 1;
            die 'incorrect @_ count to the Perl Callback' if @_ != 5;
            my $chr = $_[0];
            $chr = $_[0] & 0xFF; #x64 fill high bits with garbage
            die "bad char" if chr($chr) ne 'P';
            die "bad unsigned int64" if $_[1] != hex_to_uint64("0x12345678ABCDEF12");
            my $f4char = unpack('P4',pack(IV_LET,$_[2]));
            die "bad 4 char struct" if $f4char ne "JAPH";
            die "bad float" if $_[3] != 2.5;
            die "bad double" if $_[4] != 3.5;
            return 70000;
        },
        'I'. #the char
        'Q'. #the int 64
        'N'. #the pointer to 4 char struct
        'F'. #the float
        'D', #the double
        'N' #out type
    );
    
    $callback->UseMI64(1);
    $function = new Win32::API($test_dll, 'do_callback_5_param', 'K', 'N');
    $result = $function->Call($callback);
    is($result, 70000, "do_callback_5_param with Math::Int64 was successful");

    $callback = Win32::API::Callback->new(
    sub {
        #print Dumper(\@_);
        ok(@_ == 0,  "@_ should be empty");
        return hex_to_uint64("0x8000200030004000");
    },
    '', #nothing
    'Q' #out type
    );
    $function = new Win32::API::More($test_dll, 'do_callback_void_q', 'K', 'Q');
    $function->UseMI64(1);
    $callback->UseMI64(1);
    $result = $function->Call($callback);
    print uint64_to_hex($result)." ".uint64_to_hex(hex_to_uint64("0x8000200030004000"))."\n";
    is($result,
       hex_to_uint64("0x8000200030004000")
       , "do_callback_void_q with Math::Int64 was successful");
    #test that UseMI64 is not required for "out" params in Callback
    $callback->UseMI64(0);#use automatic MI64 "out" recoginition added in v0.71
    $result = $function->Call($callback);
    print uint64_to_hex($result)." ".uint64_to_hex(hex_to_uint64("0x8000200030004000"))."\n";
    is($result,
       hex_to_uint64("0x8000200030004000")
       , "do_callback_void_q with Math::Int64 was successful");

}#end of skip

$callback = Win32::API::Callback->new(
    sub {
        #print Dumper(\@_);
        #$DB::single = 1;
        die 'incorrect @_ count to the Perl Callback' if @_ != 5;
        my $chr = $_[0];
        $chr = $_[0] & 0xFF;
        die "bad char" if chr($chr) ne 'P';
        if(PTR_SIZE == 4){
            my ($low,$high) = unpack(IV_LET.IV_LET, $_[1]);
            die "bad unsigned int64" if $low != 0xABCDEF12;
            die "bad unsigned int64" if $high != 0x12345678;
        }else{
            no warnings 'portable', 'overflow'; #silence on 32 bits
            die "bad unsigned int64" if $_[1] != 0x12345678ABCDEF12;
        }
        my $f4char; 
        $f4char = unpack('P4',pack(IV_LET,$_[2]));
        die "bad 4 char struct" if $f4char ne "JAPH";
        die "bad float" if $_[3] != 2.5;
        die "bad double" if $_[4] != 3.5;
        return 90000;
    },
    'I'. #the char
    'Q'. #the int 64
    'N'. #the 4 char pointer
    'F'.#the float
    'D',#the double
    'N', #out type
    '__cdecl'
);
$function = new Win32::API($test_dll, 'do_callback_5_param_cdec', 'K', 'N');
$result = $function->Call($callback);
is($result, 90000, "do_callback_5_param_cdec was successful");


$callback = Win32::API::Callback->new(
    sub {
        #print Dumper(\@_);
        ok(@_ == 0,  "@_ should be empty");
        return 9876.5432;
    },
    '', #nothing
    'D' #out type
);
$function = new Win32::API($test_dll, 'do_callback_void_d', 'K', 'D');
$result = $function->Call($callback);
is($result, 9876.5432, "do_callback_void_d was successful");

$callback = Win32::API::Callback->new(
    sub {
        #print Dumper(\@_);
        ok(@_ == 0,  "@_ should be empty");
        return 2345.6789;
    },
    '', #nothing
    'F' #out type
);
$function = new Win32::API($test_dll, 'do_callback_void_f', 'K', 'F');
$result = $function->Call($callback);
#without the packs rounding errors cause a fail due to float to double casting
is(pack('f',$result), pack('f', 2345.6789), "do_callback_void_f was successful");


$callback = Win32::API::Callback->new(
    sub {
        #print Dumper(\@_);
        ok(@_ == 0,  "@_ should be empty");
        if(PTR_SIZE == 4){
            return pack(IV_LET.IV_LET, 0x30004000, 0x80002000);
        }
        else{
            no warnings 'portable', 'overflow'; #silence on 32 bits
            return 0x8000200030004000;
        }
    },
    '', #nothing
    'Q' #out type
);
$function = new Win32::API::More($test_dll, 'do_callback_void_q', 'K', 'Q');
$result = $function->Call($callback);

{
    no warnings 'portable', 'overflow'; #silence on 32 bits
    is($result,
       PTR_SIZE == 4 ? pack(IV_LET.IV_LET, 0x30004000, 0x80002000) : 0x8000200030004000
       , "do_callback_void_q was successful");
}
#
# End of tests