##!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 Config;
use File::Spec;
use Test::More;
use Math::Int64 qw( hex_to_int64 );
BEGIN {
eval { require Encode; };
if($@){
require Encode::compat;
}
Encode->import();
eval 'sub OPV () {'.$].'}';
sub OPV();
}
plan tests => 17;
use vars qw(
$function
$result
$test_dll
);
use_ok('Win32::API');
use Win32::API::Test;
ok(1, 'loaded');
$test_dll = Win32::API::Test::find_test_dll();
ok(-s $test_dll, 'found API test dll');
typedef Win32::API::Struct(
'simple_struct', qw(
int a;
double b;
LPSTR c;
DWORD_PTR d;
)
);
my $simple_struct = Win32::API::Struct->new('simple_struct');
$simple_struct->align('auto');
$simple_struct->{a} = 5;
$simple_struct->{b} = 2.5;
$simple_struct->{c} = "test";
$simple_struct->{d} = 0x12345678;
my $mangled_d;
if (Win32::API::Test::is_perl_64bit()) {
$mangled_d = 18446744073404131719
; #0xffffffffedcba987; perl errors on hex constants that large, but for some reason not decimal ones
}
else {
$mangled_d = 0xedcba987;
}
$function = new Win32::API($test_dll, 'mangle_simple_struct', 'S', 'I');
ok(defined($function), 'mangle_simple_struct() function');
diag('$^E=', $^E);
$result = $function->Call($simple_struct);
#print "\n\n\na=$simple_struct->{a} b=$simple_struct->{b} c=$simple_struct->{c} d=$simple_struct->{d}\n\n\n";
#printf "\n\n\na=%s b=%s c=%s d=%08x\n\n\n", $simple_struct->{a}, $simple_struct->{b},
# $simple_struct->{c}, $simple_struct->{d};
ok( $simple_struct->{a} == 2
&& $simple_struct->{b} == 5
&& $simple_struct->{c} eq 'TEST'
&& $simple_struct->{d} == $mangled_d,
'mangling of simple structures work'
);
my %simple_struct;
tie %simple_struct, 'Win32::API::Struct' => 'simple_struct';
tied(%simple_struct)->align('auto');
$simple_struct{a} = 5;
$simple_struct{b} = 2.5;
$simple_struct{c} = "test";
$simple_struct{d} = $mangled_d;
#printf "\n\n\na=%s b=%s c=%s d=%08x\n\n\n", $simple_struct->{a}, $simple_struct->{b},
# $simple_struct->{c}, $simple_struct->{d};
$result = $function->Call(\%simple_struct);
ok( $simple_struct{a} == 2
&& $simple_struct{b} == 5
&& $simple_struct{c} eq 'TEST'
&& $simple_struct->{d} == $mangled_d,
'tied interface works'
);
#old fashioned way first
{
$function = Win32::API->new($test_dll, 'WlanConnect', 'QNPPN', 'I');
if(IV_SIZE == 4 && defined(&Win32::API::UseMI64)){ #defined bc dont fatal error on 0.68
$function->UseMI64(1);
}
my $SSIDstruct = pack('LZ32',length("TheSSID"), "TheSSID" );
my $profname = Encode::encode("UTF-16LE","TheProfileName\x00");
my $Wlan_connection_parameters;
if(OPV > 5.007002){
$Wlan_connection_parameters = pack('Lx![p]PP'.PTR_LET().'LL', 0
,$profname
, $SSIDstruct, 0, 3, 1);
}
else {#5.6 nranch not 64 bit compatible, missing alignment
$Wlan_connection_parameters = pack('LPP'.PTR_LET().'LL', 0
,$profname
, $SSIDstruct, 0, 3, 1);
}
#$Wlan_connection_parameters->{wlanConnectionMode} = 0;
#$Wlan_connection_parameters->{strProfile} = $profilename;
#$Wlan_connection_parameters->{pDot11Ssid} = $pDot11Ssid;
#$Wlan_connection_parameters->{pDesiredBssidList} = 0;
#$Wlan_connection_parameters->{dot11BssType} = 3;
#$Wlan_connection_parameters->{dwFlags} = 1;
is($function->Call(hex_to_int64("0x8000000050000000"),
0x12344321,
"\x01\x02\x03\x04\x05\x06\x07\x08\x09\x10\x11\x12\x13\x14\x15\x16"
, $Wlan_connection_parameters,
0xF080F080), 0, "manual packing fake WlanConnect returned ERROR_SUCCESS");
}
{
Win32::API::Type->typedef( 'WLAN_CONNECTION_MODE', 'INT');
Win32::API::Type->typedef( 'DOT11_BSS_TYPE', 'INT');
Win32::API::Type->typedef( 'PDOT11_BSSID_LIST', 'UINT_PTR');
Win32::API::Struct->typedef ('DOT11_SSID', qw(
ULONG uSSIDLength;
UCHAR ucSSID[32];
));
Win32::API::Type->typedef( 'PDOT11_SSID', 'DOT11_SSID *');
Win32::API::Struct->typedef('WLAN_CONNECTION_PARAMETERS', qw(
WLAN_CONNECTION_MODE wlanConnectionMode;
LPCWSTR strProfile;
PDOT11_SSID pDot11Ssid;
PDOT11_BSSID_LIST pDesiredBssidList;
DOT11_BSS_TYPE dot11BssType;
DWORD dwFlags;
));
Win32::API::Type->typedef('PWLAN_CONNECTION_PARAMETERS', 'WLAN_CONNECTION_PARAMETERS *');
Win32::API::Type->typedef( 'GUID *', 'char *');
$function = Win32::API->new($test_dll, 'DWORD
WlanConnect(
unsigned __int64 quad,
HANDLE hClientHandle,
GUID *pInterfaceGuid,
PWLAN_CONNECTION_PARAMETERS pConnectionParameters,
UINT_PTR pReserved
)');
my $pDot11Ssid = Win32::API::Struct->new('DOT11_SSID');
$pDot11Ssid->{uSSIDLength} = length "TheSSID";
$pDot11Ssid->{ucSSID} = "TheSSID";
my $Wlan_connection_parameters = Win32::API::Struct->new('WLAN_CONNECTION_PARAMETERS');
$Wlan_connection_parameters->{wlanConnectionMode} = 0;
$Wlan_connection_parameters->{strProfile} = Encode::encode("UTF-16LE","TheProfileName\x00");
$Wlan_connection_parameters->{pDot11Ssid} = $pDot11Ssid;
$Wlan_connection_parameters->{pDesiredBssidList} = 0;
$Wlan_connection_parameters->{dot11BssType} = 3;
$Wlan_connection_parameters->{dwFlags} = 1;
{
no warnings 'portable';
is($function->Call(IV_SIZE == 4?
"\x00\x00\x00\x50\x00\x00\x00\x80":
0x8000000050000000,
0x12344321,
"\x01\x02\x03\x04\x05\x06\x07\x08\x09\x10\x11\x12\x13\x14\x15\x16",
$Wlan_connection_parameters,
0xF080F080), 0, "::Struct fake WlanConnect returned ERROR_SUCCESS");
}
Win32::API::Struct->typedef('WLANPARAMCONTAINER', 'PWLAN_CONNECTION_PARAMETERS', 'wlan;');
$function = Win32::API->new($test_dll, ' void __stdcall GetConParams('
.'BOOL Fill, WLANPARAMCONTAINER * param)');
my $Wlan_cont = Win32::API::Struct->new('WLANPARAMCONTAINER');
$Wlan_cont->{wlan} = undef;
diag("leaked mem warning intentional");
$function->Call(1, $Wlan_cont);
ok($Wlan_cont->{wlan}->{wlanConnectionMode} == 0
&& $Wlan_cont->{wlan}->{pDot11Ssid}->{ucSSID} eq "TheFilledSSID"
&& $Wlan_cont->{wlan}->{pDot11Ssid}->{uSSIDLength} == 13
&& $Wlan_cont->{wlan}->{pDesiredBssidList} == 0
#UTF16 readback is garbage b/c null termination
#&& $Wlan_cont->{wlan}->{strProfile} eq Encode::encode("UTF-16LE","FilledTheProfileName"),
,"undef child struct turned to defined");
$function->Call(0, $Wlan_cont);
ok(! defined $Wlan_cont->{wlan} ,"defined child struct turned to undefined");
}
{
ok( typedef Win32::API::Struct(
'EIGHT_CHARS', qw(
char c1;
char c2;
char c3;
char c4;
char c5;
char c6;
char c7;
char c8;
)
), "typedefing EIGHT_CHARS worked");
my $struct = Win32::API::Struct->new('EIGHT_CHARS');
for(1..8){
$struct->{'c'.$_} = 0;
}
$function = Win32::API->new($test_dll, 'void __stdcall buffer_overflow(LPEIGHT_CHARS string)');
$function->Call($struct);
for(1..8){
$struct->{'c'.$_} = pack('c', $struct->{'c'.$_});
}
ok($struct->{'c1'} eq 'J'
&&$struct->{'c2'} eq 'A'
&&$struct->{'c3'} eq 'P'
&&$struct->{'c4'} eq 'H'
&&$struct->{'c5'} eq 'J'
&&$struct->{'c6'} eq 'A'
&&$struct->{'c7'} eq 'P'
&&$struct->{'c8'} eq 'H'
, "buffer_overflow filled the struct correctly");
#now check struct type checking
$struct = Win32::API::Struct->new('simple_struct');
eval {$function->Call($struct);};
ok(index($@, "doesn't match type") != -1, "type mismatch check worked");
typedef Win32::API::Struct(
'EIGHT_CHAR_ARR', qw(
char str[8];
)
);
$struct = Win32::API::Struct->new('EIGHT_CHAR_ARR');
$struct->{str} = "\x00";
$function = Win32::API->new($test_dll, 'void __stdcall buffer_overflow(LPEIGHT_CHAR_ARR string)');
$function->Call($struct);
is($struct->{str}, 'JAPHJAPH', "buffer_overflow filled the struct correctly");
diag("unknown type is intentional");
$struct = Win32::API::Struct->new('LPEIGHT_CHAR_ARR');
#Win32::API::Struct has never known the LP____ types automatically,
#This conflicts with the v0.70 and older POD for ::Struct
#only Win32::API::Call() knows to remove the LP prefix to get the real
#struct name, actually in <=0.70, the struct's type was never matched
#to the C proto (if one exists), so any ::Struct would work, but the C
#func would get a corrupt struct then, so thats why <= 0.70 "knew" the LP
#prefix (TLDR, it doesn't know the LP prefix under the hood)
#> 0.70 got ::Struct type matching, so Call does under the hood remove
#the LP prefix if any
if(! defined $struct)
{ ok(1, "can not ::Struct::new a LP prefixed struct name for a defined struct");}
else{ #0.70 and older code path
$struct->Pack();
is($struct->{buffer}, '', "can not ::Struct::new a LP prefixed struct name for a defined struct");
}
ok(Win32::API::Type->typedef('LPEIGHT_CHAR_ARR', 'EIGHT_CHAR_ARR *')
, "Type::typedef worked");
$struct = Win32::API::Struct->new('LPEIGHT_CHAR_ARR');
ok(! defined $struct, "Type::typedef doesn't change the ::Struct db");
}