#!perl -w
# $Id$
# 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 File::Spec;
use Test::More;
use Win32::API::Test;
BEGIN {
eval { require Encode; };
if($@){
require Encode::compat;
}
Encode->import();
}
use Math::Int64 ('hex_to_int64');
plan tests => 22;
use vars qw($function $result $return $test_dll );
use_ok('Win32::API', 'SafeReadWideCString');
$test_dll = Win32::API::Test::find_test_dll();
diag('API test dll found at (' . $test_dll . ')');
ok(-e $test_dll, 'found API test dll');
#in 0.70 and older, if you typedef to a string, you actually a typedef
#to a char, C func won't get a pointer but a extended char
# Find a char in a string
Win32::API::Type->typedef('MYSTRING','char *');
$function = new Win32::API($test_dll, 'char* find_char(MYSTRING string, char ch)');
ok(defined($function), 'find_char() function defined');
#diag("$function->{procname} \$^E=", $^E);
{
my $string = 'japh';
my $char = 'a';
is($function->Call($string, $char), 'aph', 'find_char() function call works');
}
{
my $source = Encode::encode("UTF-16LE","Just another perl hacker\x00");
my $string = '';
$string = SafeReadWideCString(unpack(PTR_LET(),pack('p', $source)));
is($string, "Just another perl hacker", "SafeReadWideCString ASCII");
$string = '';
$source = Encode::encode("UTF-16LE","Just another perl h\x{00E2}cker\x00");
$string = SafeReadWideCString(unpack(PTR_LET(),pack('p', $source)));
is($string, "Just another perl h\x{00E2}cker", "SafeReadWideCString Wide");
$string = SafeReadWideCString(0);
ok(! defined $string, "SafeReadWideCString null pointer");
}
eval {
$function = new Win32::API($test_dll, 'GetHandle', 'N', 'S', '__stdcall');
};
ok(index($@, 'Win32::API invalid return type, structs and callbacks') != -1,
"Struct 'S' invalid return type");
eval {
$function = new Win32::API($test_dll, 'GetHandle', 'N', 'T', '__stdcall');
};
ok(index($@, 'Win32::API invalid return type, structs and callbacks') != -1,
"Struct 'T' invalid return type");
eval {
$function = new Win32::API($test_dll, 'GetHandle', 'N', 'K', '__stdcall');
};
ok(index($@, 'Win32::API invalid return type, structs and callbacks') != -1,
"Callback invalid return type");
eval {
$function = new Win32::API::More($test_dll, 'GetHandle', 'N', 'T', '__stdcall');
};
ok(index($@, 'Win32::API invalid return type, structs and callbacks') != -1,
"::More Struct 'T' invalid return type");
eval {
$function = new Win32::API::More($test_dll, 'GetHandle', 'N', 'K', '__stdcall');
};
ok(index($@, 'Win32::API invalid return type, structs and callbacks') != -1,
"::More Callback invalid return type");
{
$function = Win32::API->new('kernel32.dll', 'GetCurrentThreadId', 'V', 'N');
ok($function->Call(), "GetCurrentThreadId with 'V' in proto works");
$function = Win32::API->new('kernel32.dll', 'GetCurrentThreadId', ['V'], 'N');
ok($function->Call(), "GetCurrentThreadId with array 'V' in proto works");
eval{
$function = Win32::API->new('kernel32.dll', 'GetCurrentThreadId', ['V', 'N'], 'N');
};
ok(index($@, "Win32::API 'V' for in prototype must be the only parameter") != -1,
"in V proto param + other param fails");
$function = Win32::API->new('kernel32.dll', 'GetCurrentThreadId', '', 'N');
ok($function->Call(), "GetCurrentThreadId with '' in proto works");
$function = Win32::API->new('kernel32.dll', 'GetCurrentThreadId', '', '');
ok(! defined $function->Call(), "GetCurrentThreadId with '' out proto works");
$function = Win32::API->new('kernel32.dll', 'GetCurrentThreadId', '', 'V');
ok(! defined $function->Call(), "GetCurrentThreadId with '' out proto works");
}
SKIP: {
skip('Quads are native on this computer', 4) if
IV_SIZE == 8;
#test that UseMI64 is not required for non Callback "in" params
$function = new Win32::API::More($test_dll, 'LONG64 __stdcall sum_quads_ref(LONG64 a, LONG64 b, LONG64 * c)');
$result = 0; #cant be undef
diag("under 8 byte warnings are intended");
eval {
$return = $function->Call(hex_to_int64("0x0200000000000000"),
1, $result); #note, 1 isn't an int64 obj, and will produce garbage
};
ok(index($@, 'Win32::API::Call: parameter 2 must be a packed 8 bytes long string')
!= -1, "in UseMI64 off mode, numeric scalar '1' turns to bad 1 char string");
#note, 10,000,000 isn't an int64 obj, but passes length check when converted to string
#nothing can be done to protect against this usage mistake
$return = $function->Call(hex_to_int64("0x0200000000000000"), 10000000, $result);
is($return, $result, "garbage return and garbage pointer fill the same");
ok($return && $return != hex_to_int64("0x0200000000000001"),
"in UseMI64 off mode, 8 digit numeric scalar defeats 8 byte length check but produces garbage output");
$result = 0;
$return = $function->Call(hex_to_int64("0x0200000000000000"),
hex_to_int64("0x1"), $result); #note, 1 isn't an int64 obj, and will produce garbage
ok($return eq "\x01\x00\x00\x00\x00\x00\x00\x02"
&& $result eq "\x01\x00\x00\x00\x00\x00\x00\x02",
"pointer to quad is equal to returned quad without UseMI64");
}