FFI-Platypus/t/ffi_platypus_record.t
use Test2::V0 -no_srand => 1;
use FFI::Platypus;
use FFI::Platypus::Memory qw( malloc free );
use Data::Dumper;
do {
package
Foo1;
use FFI::Platypus::Record;
record_layout(
uint8 => 'first',
uint32 => 'second',
);
};
sub xdump_meta ($)
{
my($type) = @_;
my $ffi = FFI::Platypus->new;
my $object = $ffi->type_meta($type);
note(Data::Dumper->new([$object])->Indent(0)->Terse(1)->Sortkeys(1)->Dump);
}
subtest 'integer accessor' => sub {
my $foo = Foo1->new( first => 1, second => 2 );
isa_ok $foo, 'Foo1';
my $size = $foo->_ffi_record_size;
like $size, qr{^[0-9]+$}, "foo._record_size = $size";
is $foo->first, 1, 'foo.first = 1';
is $foo->second, 2, 'foo.second = 2';
$foo->first(22);
is $foo->first, 22, 'foo.first = 22';
$foo->second(42);
is $foo->second, 42, 'foo.second = 42';
$foo = Foo1->new( { first => 3, second => 4 } );
is $foo->first, 3, 'foo.first = 3';
is $foo->second, 4, 'foo.second = 4';
xdump_meta('record(Foo1)');
xdump_meta('record(8)');
};
do {
package
Color;
use FFI::Platypus;
use FFI::Platypus::Record;
my $ffi = FFI::Platypus->new;
$ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi');
record_layout($ffi, qw(
uint8 red
uint8 green
uint8 blue
));
$ffi->type('record(Color)' => 'Color');
$ffi->attach( [ color_get_red => 'get_red' ] => [ 'Color' ] => 'int' );
$ffi->attach( [ color_get_green => 'get_green' ] => [ 'Color' ] => 'int' );
$ffi->attach( [ color_get_blue => 'get_blue' ] => [ 'Color' ] => 'int' );
};
subtest 'values match in C' => sub {
my $color = Color->new(
red => 50,
green => 100,
blue => 150,
);
isa_ok $color, 'Color';
is $color->get_red, 50, "color.get_red = 50";
is $color->get_green, 100, "color.get_green = 100";
is $color->get_blue, 150, "color.get_blue = 150";
};
do {
package
Foo2;
use FFI::Platypus::Record;
record_layout(qw(
char :
uint64_t uint64
char :
uint32_t uint32
char :
uint16_t uint16
char :
uint8_t uint8
char :
int64_t sint64
char :
int32_t sint32
char :
int16_t sint16
char :
int8_t sint8
char :
float float
char :
double double
char :
opaque opaque
));
my $ffi = FFI::Platypus->new;
$ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi');
$ffi->attach(["align_get_$_" => "get_$_"] => [ 'record(Foo2)' ] => $_)
for qw( uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64 float double opaque );
};
subtest 'complex alignment' => sub {
my $foo = Foo2->new;
isa_ok $foo, 'Foo2';
$foo->uint64(512);
is $foo->get_uint64, 512, "uint64 = 512";
$foo->sint64(-512);
is $foo->get_sint64, -512, "sint64 = -512";
$foo->uint32(1024);
is $foo->get_uint32, 1024, "uint32 = 1024";
$foo->sint32(-1024);
is $foo->get_sint32, -1024, "sint32 = -1024";
$foo->uint16(2048);
is $foo->get_uint16, 2048, "uint16 = 2048";
$foo->sint16(-2048);
is $foo->get_sint16, -2048, "sint16 = -2048";
$foo->uint8(48);
is $foo->get_uint8, 48, "uint8 = 48";
$foo->sint8(-48);
is $foo->get_sint8, -48, "sint8 = -48";
$foo->float(1.5);
is $foo->get_float, 1.5, "float = 1.5";
$foo->double(-1.5);
is $foo->get_double, -1.5, "double = -1.5";
my $ptr = malloc 32;
$foo->opaque($ptr);
is $foo->get_opaque, $ptr, "get_opaque = $ptr";
is $foo->opaque, $ptr, "opaque = $ptr";
$foo->opaque(undef);
is $foo->get_opaque, undef, "get_opaque = undef";
is $foo->opaque, undef, "opaque = undef";
free $ptr;
};
subtest 'same name' => sub {
eval {
package
Foo3;
require FFI::Platypus::Record;
FFI::Platypus::Record->import;
record_layout(
int => 'foo',
int => 'foo',
);
};
isnt $@, '', 'two members of the same name not allowed';
note $@ if $@;
};
do {
package
Foo4;
use FFI::Platypus::Record;
record_layout(qw(
char :
uint64_t[3] uint64
char :
uint32_t[3] uint32
char :
uint16_t[3] uint16
char :
uint8_t[3] uint8
char :
int64_t[3] sint64
char :
int32_t[3] sint32
char :
int16_t[3] sint16
char :
int8_t[3] sint8
char :
float[3] float
char :
double[3] double
char :
opaque[3] opaque
));
my $ffi = FFI::Platypus->new;
$ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi');
$ffi->attach(["align_array_get_$_" => "get_$_"] => [ 'record(Foo4)' ] => "${_}[3]" )
for qw( uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64 float double opaque );
};
subtest 'array alignment' => sub {
my $foo = Foo4->new;
isa_ok $foo, 'Foo4';
foreach my $bits (qw( 8 16 32 64 ))
{
subtest "unsigned $bits integer" => sub {
my $acc1 = "uint$bits";
my $acc2 = "get_uint$bits";
$foo->$acc1([1,2,3]);
is $foo->$acc1, [1,2,3], "$acc1 = 1,2,3";
is $foo->$acc2, [1,2,3], "$acc2 = 1,2,3";
is $foo->$acc1(1), 2, "$acc1(1) = 2";
$foo->$acc1(1,20);
is $foo->$acc1, [1,20,3], "$acc1 = 1,20,3";
};
subtest "signed $bits integer" => sub {
my $acc1 = "sint$bits";
my $acc2 = "get_sint$bits";
$foo->$acc1([-1,2,-3]);
is $foo->$acc1, [-1,2,-3], "$acc1 = -1,2,-3";
is $foo->$acc2, [-1,2,-3], "$acc2 = -1,2,-3";
is $foo->$acc1(2), -3, "$acc1(2) = -3";
$foo->$acc1(1,-20);
is $foo->$acc1, [-1,-20,-3], "$acc1 = -1,-20,-3";
};
}
foreach my $type (qw( float double ))
{
subtest $type => sub {
$foo->$type([1.5,undef,-1.5]);
is $foo->$type, [1.5,0.0,-1.5], "$type = 1.5,0,-1.5";
is $foo->$type(0), 1.5;
is $foo->$type(1), 0.0;
is $foo->$type(2), -1.5;
$foo->$type(1,20.0);
is $foo->$type, [1.5,20.0,-1.5], "$type = 1.5,20,-1.5";
};
}
subtest 'opaque' => sub {
my $ptr1 = malloc 32;
my $ptr2 = malloc 64;
$foo->opaque([$ptr1,undef,$ptr2]);
is $foo->opaque, [$ptr1,undef,$ptr2], "opaque = $ptr1,undef,$ptr2";
$foo->opaque(1,$ptr1);
is $foo->opaque, [$ptr1,$ptr1,$ptr2], "opaque = $ptr1,$ptr1,$ptr2";
$foo->opaque(0,undef);
is $foo->opaque, [undef,$ptr1,$ptr2], "opaque = undef,$ptr1,$ptr2";
is $foo->opaque(0), undef;
is $foo->opaque(1), $ptr1;
is $foo->opaque(2), $ptr2;
free $ptr1;
free $ptr2;
};
my $align = $foo->_ffi_record_align;
like $align, qr{^[0-9]+$}, "align = $align";
ok $align > 0, "align is positive";
};
do {
package
Foo5;
use FFI::Platypus::Record;
record_layout(qw(
char :
string value
));
my $ffi = FFI::Platypus->new;
$ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi');
$ffi->attach(
[align_string_get_value => 'get_value'] => ['record(Foo5)'] => 'string',
);
$ffi->attach(
[align_string_set_value => 'set_value'] => ['record(Foo5)','string'] => 'void',
);
};
subtest 'string ro' => sub {
my $foo = Foo5->new;
isa_ok $foo, 'Foo5';
is $foo->value, undef, 'foo.value = undef';
is $foo->get_value, undef, 'foo.get_value = undef';
$foo->set_value("my value");
is $foo->value, 'my value', 'foo.value = my value';
is $foo->get_value, 'my value', 'foo.get_value = my value';
eval { $foo->value("stuff") };
isnt $@, '', 'value is ro';
note $@ if $@;
$foo->set_value(undef);
is $foo->value, undef, 'foo.value = undef';
is $foo->get_value, undef, 'foo.get_value = undef';
};
do {
package
Foo6;
use FFI::Platypus::Record;
record_layout(qw(
char :
string(10) value
));
my $ffi = FFI::Platypus->new;
$ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi');
$ffi->attach([align_fixed_get_value=>'get_value'] => ['record(Foo6)'] => 'string');
};
subtest 'fixed string' => sub {
my $foo = Foo6->new;
isa_ok $foo, 'Foo6';
is $foo->value, "\0\0\0\0\0\0\0\0\0\0", 'foo.value = "\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0"';
is $foo->get_value, "", 'foo.get_value = ""';
$foo->value("one two three four five six seven eight");
is $foo->value, "one two th", 'foo.value = "one two th"';
$foo->value("123456789\0");
is $foo->value, "123456789\0", "foo.value = 123456789\\0";
is $foo->get_value, "123456789", "foo.get_value = 123456789";
};
do {
package
Foo7;
use FFI::Platypus::Record;
record_layout(qw(
char :
string_rw value
));
my $ffi = FFI::Platypus->new;
$ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi');
$ffi->attach(
[align_string_get_value => 'get_value'] =>
['record(Foo7)'] => 'string'
);
};
subtest 'string rw' => sub {
my $foo = Foo7->new;
isa_ok $foo, 'Foo7';
$foo->value('hi there');
is $foo->value, "hi there", "foo.value = hi there";
is $foo->get_value, 'hi there', 'foo.get_value = hi there';
$foo->value(undef);
is $foo->value, undef, 'foo.value = undef';
is $foo->get_value, undef, 'foo.get_value = undef';
$foo->value('starscream!!!');
is $foo->value, "starscream!!!", "foo.value = starscream!!!";
is $foo->get_value, 'starscream!!!', 'foo.get_value = starscream!!!';
};
subtest 'record with custom ffi' => sub {
{
package
Foo8;
use FFI::Platypus::Record;
my $ffi = FFI::Platypus->new;
$ffi->type('string rw' => 'foo_t');
record_layout($ffi, qw(
foo_t foo
));
}
my $foo8 = Foo8->new;
isa_ok $foo8, 'Foo8';
$foo8->foo("yo this is a string");
is( $foo8->foo, "yo this is a string" );
};
subtest 'record with ffi args' => sub {
{ package
FFI::Platypus::Lang::Foo9;
sub native_type_map
{
return { foo_t => 'sint32' };
}
}
{ package
Foo9;
use FFI::Platypus::Record;
record_layout
[ lang => 'Foo9', api => 1 ],
foo_t => 'foo'
;
}
my $foo8 = Foo8->new;
isa_ok $foo8, 'Foo8';
$foo8->foo(-42);
is( $foo8->foo, -42 );
};
subtest 'api_1' => sub {
my $api;
my $ffi = FFI::Platypus->new;
no warnings 'once';
no warnings 'redefine';
local *FFI::Platypus::new = do {
my $orig = FFI::Platypus->can('new');
sub {
my $class = shift;
my %args = @_;
$api = $args{api};
$api = 0 unless defined $args{api};
$class->$orig(@_);
};
};
subtest 'no $ffi or args' => sub {
local $@;
undef $api;
eval q{
package Foo10;
use FFI::Platypus::Record;
record_layout_1(
string => 'a',
);
};
is "$@", '';
is( $api, 2 );
};
subtest 'args' => sub {
local $@;
undef $api;
eval q{
package Foo11;
use FFI::Platypus::Record;
record_layout_1( [],
string => 'a',
);
};
is "$@", '';
is( $api, 2 );
};
subtest '$ffi' => sub {
local $@;
undef $api;
eval q{
package Foo12;
use FFI::Platypus::Record;
record_layout_1( $ffi,
string => 'a',
);
};
is "$@", '';
is( $api, undef );
};
};
done_testing;