view release on metacpan or  search on metacpan

t/019_fileio.t  view on Meta::CPAN

        };
        subtest 'Returning a FILE* from C to Perl' => sub {
            my $fh = c_create_tmpfile();
            ok $fh, 'Received a filehandle from C';

            # Affix returns a Glob reference for files
            is ref($fh), 'GLOB', 'Returned handle is a Glob reference';
            my $line = <$fh>;
            is $line, 'Content from C', 'Perl can read from the C-created FILE*';

            # C-created tmpfiles usually disappear on close, simply ensure no crash
            close $fh;
        };
        subtest 'Passing invalid handles' => sub {

            # Passing undef/closed handle should result in NULL on C side
            is c_is_null_file(undef), 1, 'Passing undef results in NULL FILE*';
        }
    };
    subtest 'PerlIO* Streams (Affix::PerlIO)' => sub {

        # Bind the identity function using PerlIO type
        affix $lib, 'c_perlio_identity', [ Pointer [PerlIO] ] => Pointer [PerlIO];

        # Test Roundtrip
        # Note: PerlIO* handles are generally strictly tied to the Perl layer.
        # When passed to C, we extract the PerlIO*, pass it, and wrap it in a new Glob on return.
        my ( $fh, $filename ) = tempfile();
        syswrite $fh, 'Test Data';
        seek( $fh, 0, 0 );
        my $new_fh = c_perlio_identity($fh);
        ok $new_fh, 'Received handle back from C';
        is ref($new_fh), 'GLOB', 'Returned handle is a Glob reference';

        # Since it's the same underlying stream, reading from one should advance the other
        # or at least access the same data source.
        my $line = <$new_fh>;
        is $line, 'Test Data', 'Round-tripped PerlIO handle is readable';
        close $fh;
        close $new_fh;    # Should be safe to close the wrapper
        unlink $filename;
    }
};
#
subtest complex => sub {
    my $lib = compile_ok(<<~'END_C');
        #include "std.h"
        //ext: .c

        #include <stdio.h>
        #include <string.h>

        // Define a struct that contains a file pointer
        typedef struct {
            FILE* log_file;
            int   counter;
        } Logger;

        // Initialize logger with a file
        DLLEXPORT void init_logger(Logger* logger, FILE* fp) {
            if (!fp) fprintf(stderr, "C-side Warning: fp is NULL\n");
            logger->log_file = fp;
            logger->counter = 0;
        }

        // Write to a file retrieved from the struct
        DLLEXPORT void log_message(Logger* logger, const char* msg) {
            if (logger->log_file) {
                fprintf(logger->log_file, "[%d] %s\n", ++logger->counter, msg);
                fflush(logger->log_file);
            }
        }

        // Return a struct containing a file pointer
        DLLEXPORT Logger create_logger(FILE* fp) {
            Logger l;
            l.log_file = fp;
            l.counter = 100;
            return l;
        }
        END_C

    # Define the struct type in Perl.
    # Use Pointer[File] because the C struct member is FILE*.
    typedef Logger => Struct [ log_file => Pointer [File], counter => Int ];

    # Bind functions
    affix $lib, 'init_logger',   [ Pointer [ Logger() ], Pointer [File] ] => Void;
    affix $lib, 'log_message',   [ Pointer [ Logger() ], String ]         => Void;
    affix $lib, 'create_logger', [ Pointer [File] ] => Logger();
    subtest 'File inside Struct (Pointer)' => sub {
        my ( $fh, $filename ) = tempfile();
        my $old_fh = select($fh);
        $| = 1;
        select($old_fh);

        # Allocate struct memory
        my $logger = malloc( sizeof( Logger() ) );

        # Pass filehandle to C to store in struct
        init_logger( $logger, $fh );

        # Verify via C function
        log_message( $logger, 'First message' );
        log_message( $logger, 'Second message' );

        # Verify Perl side struct access
        # Note: Pulling a File handle usually creates a new GLOB wrapper around the FILE*
        # Since we own $fh, let's verify checking against undef works
        my $logger_struct = cast( $logger, Logger() );    # View as struct
        my $retrieved_fh  = $logger_struct->{log_file};
        ok $retrieved_fh, 'Retrieved filehandle from struct';
        is ref($retrieved_fh), 'GLOB', 'It is a glob';

        # Write from Perl using retrieved handle
        # print {$retrieved_fh} "From Perl\n"; # Careful, might double-close if not careful
        # Check file content
        open my $check, '<', $filename;
        my @lines = <$check>;
        close $check;
        is scalar(@lines), 2, 'File has 2 lines';