view release on metacpan or  search on metacpan

t/999_marshaller_2.t  view on Meta::CPAN

    # Set deep values
    $mgr->{name}           = "Alice";
    $mgr->{tasks}[0]{id}   = 101;
    $mgr->{tasks}[0]{name} = "FFI Core";
    $mgr->{tasks}[1]{id}   = 102;
    $mgr->{tasks}[1]{name} = "Marshal v2";

    # TEST DEEP ACCESS: $comp -> manager (ptr) -> tasks (array) -> name (string)
    is $comp->{manager}{name},         "Alice", 'Deep Read: manager->name';
    is $comp->{manager}{tasks}[0]{id}, 101,     'Deep Read: manager->tasks[0]->id';

    # TEST DEEP WRITE via the pointer member
    $comp->{manager}{tasks}[0]{id} = 999;
    is $mgr->{tasks}[0]{id}, 999, 'Deep Write confirmed in original memory';

    # Reset for verification function
    $comp->{manager}{tasks}[0]{id} = 101;

    # Pass to C
    ok verify_hierarchy($comp), 'FFI: verify_hierarchy($comp) - deep validation passed';
};
subtest 'smart & safety' => sub {

    # Types were defined in previous subtests
    affix $lib_path, 'get_null_company', [], Pointer [ Company() ];
    ok my $mem_comp = alloc_owned( sizeof( Company() ) ),  'alloc Company';
    ok my $mem_mgr  = alloc_owned( sizeof( Employee() ) ), 'alloc Manager';
    ok my $comp     = cast( $mem_comp, Company() ),        'cast Company';
    ok my $mgr      = cast( $mem_mgr, Employee() ),        'cast Manager';
    $mgr->{name}    = "Bob";
    $comp->{budget} = 50000;

    # We assign the $mgr pin DIRECTLY to the manager pointer field.
    $comp->{manager} = $mgr;
    is address( $comp->{manager} ), address($mgr), 'Smart Assignment: Pin converted to address automatically';
    is $comp->{manager}{name},      "Bob",         'Data accessible through smart-assigned pointer';

    # Traversing a NULL pointer in a struct
    $comp->{manager} = undef;    # Set C pointer to NULL
    like dies { $comp->{manager}{name} }, qr[undefined value], 'Accessing NULL pointer member is a fatal exception';

    # returning NULL
    ok my $null_comp = get_null_company(), 'C returns pointer to struct with NULL member';
    is $null_comp->{manager}, undef, 'C NULL pointer correctly becomes Perl undef';

    # Deep Null
    like dies { $null_comp->{manager}{tasks}[0]{id} }, qr[undefined value], 'Deep access on C NULL throws Perl exception';
};
subtest 'Giant Array & Anon Types' => sub {
    my $type = Struct [ a => Int, b => Int ];
    my $mem  = alloc_owned( sizeof($type) );

    # TEST ANONYMOUS TYPE EVAPORATION
    {
        my $p = cast( $mem, $type );
        is $p->{a}, 0, 'Anonymous struct works';
    }

    # At this point, free_v2_pin was called, and the local arena for that
    # struct definition is gone. No leak in the global registry!
    # TEST GIANT ARRAY SWITCH
    # Imagine a C array of 10,000 ints
    typedef BigArray => Array [ Int, 10000 ];
    $mem = alloc_owned( sizeof( BigArray() ) );
    my $arr_pin = cast( $mem, BigArray() );

    # $arr_pin is currently a scalar (Lazy Placeholder)
    #~ ok !SvROK($arr_pin), 'Giant array is still a lazy scalar';
    # Accessing it vivifies the AV
    is $arr_pin->[500], 0, 'Accessing giant array element vivifies it on demand';

    #~ ok SvROK($arr_pin), 'Now it is a real array reference';
};
subtest calculator => sub {
    typedef MockObj    => Struct [ id => Int ];
    typedef calc_t     => Callback [ [ Int, Int ] => Int ];
    typedef Calculator => Struct [ operation => calc_t() ];
    my $lib = Affix::load_library($lib_path);    # Load library object for find_symbol
    subtest 'calculator' => sub {
        subtest 'C++ Destructors' => sub {
            affix $lib, 'mock_new', [Int], Pointer [ MockObj() ];

            #~ affix $lib, 'mock_delete',          [ Pointer [ MockObj() ] ], Void;
            affix $lib, 'get_destructor_count', [], Int;
            {
                ok my $raw_ptr = mock_new(42), 'Create native object';
                my $addr = address($raw_ptr);

                # find_symbol returns a v1 Pin. address_v2 now recognizes its vtable.
                my $sym = Affix::find_symbol( $lib, 'mock_delete' );
                ok is_pin($sym), 'find_symbol returns a pin';
                my $dtor = Affix::address($sym);
                diag sprintf( "DTOR ADDR: 0x%x\n", $dtor );
                ok $dtor,                                    'Resolved destructor address from v1 symbol pin';
                ok my $managed = wrap_owned( $addr, $dtor ), 'wrap_owned with mock_delete';
                is get_destructor_count(), 0, 'Destructor not called yet';
            }
            is get_destructor_count(), 1, 'wrap_owned triggered native destructor';
        };
        subtest 'Function Pointers' => sub {
            affix $lib, 'run_calc', [ Pointer [ Calculator() ], Int, Int ], Int;
            ok my $mem  = alloc_owned( sizeof( Calculator() ) ), 'alloc Calculator';
            ok my $calc = cast( $mem, Calculator() ),            'cast Calculator';

            # First assignment
            $calc->{operation} = sub ( $a, $b ) { return $a * $b; };
            is run_calc( $calc, 10, 5 ), 50, 'C called Perl sub (10 * 5)';

            #~ Affix::sv_dump($calc);
            # Second assignment - Prioritizing the Sub check allows this to update
            $calc->{operation} = sub ( $a, $b ) { return $a + $b; };

            #~ Affix::sv_dump($calc);
            is run_calc( $calc, 10, 5 ), 15, 'Updated function pointer to different sub (10 + 5)';

            # Extract the native C function directly from the struct
            my $native_sub = $calc->{operation};

            # Validate that we successfully wrapped it into a Perl CV
            is ref($native_sub), 'Affix', 'Extracted function pointer is a callable Affix CV';