view release on metacpan or  search on metacpan

t/013_callbacks.t  view on Meta::CPAN

    isa_ok my $harness
        = wrap( $lib_path, 'call_kitchen_sink',
        [ Callback [ [ SInt32, Float64, SInt32, Float64, SInt32, Float64, SInt32, Float64, Pointer [Char], Pointer [SInt32] ] => Void ] ] => SInt32 ),
        ['Affix'];
    my $callback_sub = sub( $a, $b, $c, $d, $e, $f, $g, $h, $i, $j_ref ) {
        is $a,      1,              'Callback arg 1 (int)';
        is $b,      2.0,            'Callback arg 2 (double)';
        is $c,      3,              'Callback arg 3 (int)';
        is $d,      4.0,            'Callback arg 4 (double)';
        is $e,      5,              'Callback arg 5 (int)';
        is $f,      6.0,            'Callback arg 6 (double)';
        is $g,      7,              'Callback arg 7 (int)';
        is $h,      8.0,            'Callback arg 8 (double)';
        is $i,      'kitchen sink', 'Callback arg 9 (string)';
        is $$j_ref, 100,            'Callback arg 10 (int*)';
        $$j_ref = 200;
    };
    is $harness->($callback_sub), 201, 'return value';
};
subtest simple => sub {
    typedef Point => Struct [ x => Int, y => Int ];
    typedef Rect => Struct [ top_left => Point(), bottom_right => Point(), label => Array [ Char, 16 ] ];
    isa_ok my $map = wrap( $lib_path, 'map_int', [ Int, Callback [ [Int] => Int ] ] => Int ), ['Affix'];
    my $res = $map->(
        10,
        sub {
            my $v = shift;
            return $v * 2;
        }
    );
    is $res, 20, 'Simple callback executed';
    #
    isa_ok my $inspect = wrap( $lib_path, 'inspect_rect', [ Pointer [ Rect() ], Callback [ [ Pointer [ Rect() ] ] => Void ] ] => Void ), ['Affix'];
    my $r = { top_left => { x => 1, y => 1 }, bottom_right => { x => 2, y => 2 }, label => "Check" };
    my $seen_label;
    $inspect->(
        $r,
        sub {
            my $ptr = shift;

            # $$ptr reads the struct (HashRef)
            # $ptr is now a Pin (scalar ref), so we must dereference it to get the hash.
            my $struct = $$ptr;
            $seen_label = $struct->{label};

            # Modify and write back
            $struct->{label} = "Checked";
            $$ptr = $struct;
        }
    );
    is $seen_label, "Check", 'Callback received struct pointer correctly';
    #
    isa_ok my $chk_pt = wrap( $lib_path, 'check_point_gen', [ Callback [ [] => Point() ] ] => Int ), ['Affix'];
    my $sum = $chk_pt->(
        sub {
            return { x => 7, y => 8 };
        }
    );
    is $sum, 15, 'Callback returned struct by value correctly';
};
subtest 'unions passed to callbacks' => sub {
    ok typedef( MyUnion => Union [ i => SInt32, f => Float32, c => Array [ Char, 8 ] ] ), 'typedef @MyUnion';
    isa_ok my $invoke = wrap( $lib_path, 'invoke_union_cb', [ Callback [ [ Pointer [ MyUnion() ] ] => Void ] ] => Int ), ['Affix'];
    my $cb = sub($pin) {

        # Dereference the pin
        my $u = $$pin;
        is $u->{i}, 42, 'Read integer member from union pointer directly';    # magical

        # IEEE 754 2.0f is 0x40000000 (1073741824 decimal)
        $u->{f} = 2.0;
    };
    my $ret = $invoke->($cb);

    # Verify the write inside the callback persisted to the C caller
    is $ret, 1073741824, 'Callback modifications persisted to C (Union write-back)';
};
subtest 'ThisCall Sugar' => sub {
    my $cb = ThisCall( Callback( [ [ Int() ] => Void() ] ) );
    is $cb->signature, '*((*void,int)->void)', 'ThisCall prepends Pointer[Void] (*void)';
    my $str = ThisCall('*((int)->void)');
    is $str, '*((*void,int)->void)', 'ThisCall also works on signature strings';
};
#
done_testing;