view release on metacpan or  search on metacpan

fuzz/fuzz_shared_lib.pl  view on Meta::CPAN

use v5.40;
use blib;
use lib 'blib/lib', 'lib';
use Affix               qw[:all];
use Test2::Tools::Affix qw[:all];
use Test2::V0 -no_srand => 1;
use Config;
use Data::Dumper;
$Data::Dumper::Terse = 1;
$|++;
#
my $max_iter = $ENV{FUZZ_MAX_ITER} // 1000;
my $timeout  = $ENV{FUZZ_TIMEOUT}  // 5;
my $verbose  = $ENV{FUZZ_VERBOSE}  // 0;
sub compile_source ($code) { compile_ok( <<~'' . $code ) }
	#include <inttypes.h>
	#include <locale.h>
	#include <math.h>
	#include <stdbool.h>
	#include <stddef.h>  // offsetof
	#include <stdio.h>
	#include <stdlib.h>  // malloc
	#include <string.h>
    #include <stdint.h>
	#include <wchar.h>
	// Some tests might actually include perl.h which has the real version of this
	#if !defined(warn)
	#define warn(FORMAT, ...)                                                          \
	    fprintf(stderr, FORMAT " at %s line %i\n", ##__VA_ARGS__, __FILE__, __LINE__); \
	    fflush(stderr);
	#endif
	#if defined _WIN32 || defined __CYGWIN__
	#include <BaseTsd.h>
	//typedef SSIZE_T ssize_t;
	typedef signed __int64 int64_t;
	#ifdef __GNUC__
	#define DLLEXPORT __attribute__((dllexport))
	#else
	#define DLLEXPORT __declspec(dllexport)
	#endif
	#else
	#ifdef __GNUC__
	#if __GNUC__ >= 4
	#define DLLEXPORT __attribute__((visibility("default")))
	#else
	#define DLLEXPORT __attribute__((dllimport))
	#endif
	#else
	#define DLLEXPORT __declspec(dllexport)
	#endif
	#include <inttypes.h>
	#include <sys/types.h>
	#endif
	//ext: .c


# Type catalog: { c_type, infix_sig, perl_type, gen_value }
# Ranges are derived from sizeof() at runtime so they match the actual platform.
my @PRIMITIVES;
{
    my @signed_ints = (
        [ 'int8_t',    'sint8',    sub { SInt8() } ],
        [ 'int16_t',   'sint16',   sub { SInt16() } ],
        [ 'int32_t',   'sint32',   sub { SInt32() } ],
        [ 'int64_t',   'sint64',   sub { SInt64() } ],
        [ 'char',      'char',     sub { Char() } ],
        [ 'short',     'short',    sub { Short() } ],
        [ 'int',       'int',      sub { Int() } ],
        [ 'long',      'long',     sub { Long() } ],
        [ 'long long', 'longlong', sub { LongLong() } ]
    );
    my @unsigned_ints = (
        [ 'uint8_t',            'uint8',     sub { UInt8() } ],
        [ 'uint16_t',           'uint16',    sub { UInt16() } ],
        [ 'uint32_t',           'uint32',    sub { UInt32() } ],
        [ 'uint64_t',           'uint64',    sub { UInt64() } ],
        [ 'unsigned char',      'uchar',     sub { UChar() } ],
        [ 'unsigned short',     'ushort',    sub { UShort() } ],
        [ 'unsigned int',       'uint',      sub { UInt() } ],
        [ 'unsigned long',      'ulong',     sub { ULong() } ],
        [ 'unsigned long long', 'ulonglong', sub { ULongLong() } ]
    );
    my @floats = ( [ 'float', 'float', sub { Float() } ], [ 'double', 'double', sub { Double() } ] );
    my @bool   = ( [ 'bool',  'bool',  sub { Bool() } ] );
    for my $entry (@signed_ints) {
        my ( $c, $sig, $perl ) = @$entry;
        my $bits = sizeof( $perl->() ) * 8;
        my $half = 2**( $bits - 1 );
        push @PRIMITIVES, { c => $c, sig => $sig, perl => $perl, gen => sub { int( rand( $half * 2 ) ) - $half } };
    }
    for my $entry (@unsigned_ints) {
        my ( $c, $sig, $perl ) = @$entry;
        my $bits = sizeof( $perl->() ) * 8;
        my $max  = 2**$bits;
        push @PRIMITIVES, { c => $c, sig => $sig, perl => $perl, gen => sub { int( rand($max) ) } };
    }
    for my $entry (@floats) {
        my ( $c, $sig, $perl ) = @$entry;
        my $prec = sizeof( $perl->() ) == 4 ? 2 : 4;
        push @PRIMITIVES, { c => $c, sig => $sig, perl => $perl, gen => sub { sprintf( "%.*f", $prec, rand(100) - 50 ) } };
    }
    for my $entry (@bool) {
        my ( $c, $sig, $perl ) = @$entry;
        push @PRIMITIVES, { c => $c, sig => $sig, perl => $perl, gen => sub { int( rand(2) ) } };
    }
}
my @SPECIAL = (
    { c => 'size_t',    sig => 'size_t',  perl => sub { Size_t() },  gen => sub { int( rand(1000) ) } },
    { c => 'ssize_t',   sig => 'ssize_t', perl => sub { SSize_t() }, gen => sub { int( rand(1000) ) } },
    { c => 'ptrdiff_t', sig => 'long',    perl => sub { Long() },    gen => sub { int( rand(200) ) - 100 } }
);
sub pick (@list) { $list[ int( rand(@list) ) ] }

sub pick_n ( $n, @list ) {
    my @shuffled = sort { rand(1) <=> rand(1) } @list;
    return @shuffled[ 0 .. $n - 1 ] if $n <= @list;
    return @shuffled;

fuzz/fuzz_shared_lib.pl  view on Meta::CPAN

            },
        ],
        verify => sub ($result) {
            my $expected = $captured_struct->{m0};
            is( $result, $expected,
                "callback struct-by-value roundtrip (expected: $expected, got: " . ( defined $result ? $result : 'undef' ) . ")" );
        },
    };
}

# Callback with struct return (reverse trampoline returning struct by value)
sub generate_callback_struct_ret_fn {
    my ($fn_name) = @_;
    my @all = grep {
        $_->{c} ne 'float'             &&
            $_->{c} ne 'double'        &&
            $_->{c} ne 'char'          &&
            $_->{c} ne 'unsigned char' &&
            $_->{c} ne 'bool'          &&
            sizeof( $_->{perl}->() )
            <= 4
    } @PRIMITIVES;
    my @fields      = pick_n( 2, @all );           # 2-field struct
    my $struct_name = 'CR' . int( rand(99999) );
    my ( @struct_members, @struct_perl_fields, @struct_sig_fields );
    for my $i ( 0 .. $#fields ) {
        my $f = $fields[$i];
        push @struct_members,     "$f->{c} m$i;";
        push @struct_perl_fields, "m$i", $f->{perl}->();
        push @struct_sig_fields,  "m$i:" . $f->{sig};
    }
    my $struct_body = join( ' ', @struct_members );
    my $struct_sig  = '{' . join( ',', @struct_sig_fields ) . '}';
    my $cb_name     = 'cb_' . int( rand(99999) );

    # C: callback takes int arg, returns struct; wrapper calls it and returns m0
    my $ret_c  = $fields[0]->{c};
    my $c_code = <<"END_C";
typedef struct { $struct_body } $struct_name;

typedef $struct_name (*$cb_name)(int);

$ret_c $fn_name($cb_name op, int x) {
    $struct_name s = op(x);
    return s.m0;
}
END_C
    my $perl_struct = Struct [@struct_perl_fields];
    my $val         = $fields[0]->{gen}->();
    return {
        c_code     => $c_code,
        c_name     => $fn_name,
        sig_args   => [ "(*($struct_sig)->int)", 'int' ],
        sig_ret    => $fields[0]->{sig},
        perl_args  => [ Callback [ [ Int() ] => $perl_struct ], Int() ],
        perl_ret   => $fields[0]->{perl}->(),
        gen_values => [
            sub {
                sub ($x) { { m0 => $val } }    # callback: return struct with m0 = val
            },
            sub {$val},                        # argument x (ignored by callback logic)
        ],
        verify => sub ($result) {
            my $ok = $result == $val;
            unless ($ok) {
                diag "callback struct ret: got=$result expected=$val";
            }
            ok( $ok, "callback struct-return roundtrip" );
        },
    };
}

# Bitfield struct (random widths 1-31, tests bitfield layout/marshalling)
sub generate_bitfield_fn {
    my ($fn_name)   = @_;
    my $struct_name = 'BF' . int( rand(99999) );
    my $nfields     = 2 + int( rand(2) );          # 2..3 bitfields
    my ( @struct_members, @struct_perl_fields, @struct_sig_fields, @c_params, @perl_args, @sig_args, @gen_values );
    my @widths;
    my @values;
    for my $i ( 0 .. $nfields - 1 ) {
        my $width = 1 + int( rand(31) );           # 1..31 bits
        push @widths, $width;
        my $max_val = ( 1 << $width ) - 1;
        my $val     = int( rand( $max_val + 1 ) );
        push @values, $val;
        my $fname = 'm' . $i;
        push @struct_members,     "uint32_t $fname : $width;";
        push @struct_perl_fields, $fname, UInt32(), $width;
        push @struct_sig_fields,  "$fname:uint32:$width";
        my $pname = "p$i";
        push @c_params,  "uint32_t $pname";
        push @perl_args, UInt32();
        push @sig_args,  'uint';
    }
    my $struct_body = join( ' ', @struct_members );
    my $struct_sig  = '{' . join( ',', @struct_sig_fields ) . '}';

    # C: take struct by value, return sum of all bitfield members
    my $sum_expr = join( ' + ', map {"s.m$_"} 0 .. $nfields - 1 );
    my $c_code   = <<"END_C";
typedef struct { $struct_body } $struct_name;

uint32_t $fn_name($struct_name s) {
    return $sum_expr;
}
END_C
    my $struct_type = Struct [@struct_perl_fields];
    my $expected    = 0;
    $expected += $_ for @values;
    return {
        c_code     => $c_code,
        c_name     => $fn_name,
        sig_args   => [$struct_sig],
        sig_ret    => 'uint',
        perl_args  => [$struct_type],
        perl_ret   => UInt32(),
        gen_values => [
            sub {
                my %h;
                for my $i ( 0 .. $nfields - 1 ) {