view release on metacpan or  search on metacpan

builder/Affix/Builder.pm  view on Meta::CPAN

        my %dist_shared   = map { $_ => catfile( qw[blib lib auto share dist],   $meta->name, abs2rel( $_, 'share' ) ) } find( qr/(?:)/, 'share' );
        my %module_shared = map { $_ => catfile( qw[blib lib auto share module], abs2rel( $_, 'module-share' ) ) } find( qr/(?:)/, 'module-share' );
        pm_to_blib( { %modules, %docs, %scripts, %dist_shared, %module_shared }, catdir(qw[blib lib auto]) );
        make_executable($_) for values %scripts;
        make_path( catdir(qw[blib arch]), { chmod => 0755, verbose => $verbose } );
        0;
    }

    method _clean_objects() {
        my $lib_dir = path('lib');
        my @objs;
        $lib_dir->visit(
            sub ( $path, $state ) {
                push @objs, $path if $path->is_file && $path =~ /\.(?:o|obj)\z/i;
            },
            { recurse => 1 }
        );
        remove_tree( $_, { verbose => $verbose } ) for @objs;
        0;
    }

    method step_clean() {
        remove_tree( $_, { verbose => $verbose } ) for qw[blib temp];
        $self->_clean_objects;
        0;
    }

    method step_install() {
        $self->step_build() unless -d 'blib';
        my %res;
        install(
            [   from_to     => $install_paths->install_map,
                verbose     => $verbose,
                always_copy => 1,
                dry_run     => $dry_run,
                uninst      => $uninst,
                result      => \%res
            ]
        );

        # In the future, I might check the values of %res according to https://metacpan.org/pod/ExtUtils::Install#install
        0;
    }

    method step_realclean () {
        remove_tree( $_,                { verbose => $verbose } ) for qw[blib temp Build _build_params MYMETA.yml MYMETA.json];
        remove_tree( 'infix/build_lib', { verbose => $verbose } );
        $self->_clean_objects;
        0;
    }

    method step_test() {
        $self->step_build() unless -d 'blib';
        require TAP::Harness::Env;
        my %test_args = (
            ( verbosity => $verbose ),
            ( jobs  => $jobs ),
            ( color => -t STDOUT ),
            lib => [ map { rel2abs( catdir( 'blib', $_ ) ) } qw[arch lib] ],
        );
        TAP::Harness::Env->create( \%test_args )->runtests( sort map { $_->stringify } find( qr/\.t$/, 't' ) )->has_errors;
    }

    method step_fuzz(@args) {
        my %args = @args;
        $self->step_build() unless -d 'blib';

        # Fuzz config via env vars (or caller can pass %args)
        my $max_iter     = $ENV{FUZZ_MAX_ITER} // $args{iter}    // 10000;
        my $timeout      = $ENV{FUZZ_TIMEOUT}  // $args{timeout} // 5;
        my $verbose_fuzz = $ENV{FUZZ_VERBOSE}  // $args{verbose} // 0;

        # Determine which Perl targets to run
        my @targets;
        if ( $args{all} ) {
            @targets = qw[wrap grammar register cross compile];
        }
        elsif ( $args{smoke} ) {
            @targets = qw[wrap grammar register cross];
        }
        elsif ( $args{target} ) {
            @targets = ref $args{target} ? @{ $args{target} } : ( $args{target} );
        }
        else {
            @targets = qw[wrap grammar register cross];
        }

        # Perl fuzz target metadata
        my %perl_targets = (
            wrap     => { script => 'fuzz_wrap_type_sig.pl',  desc => 'Affix::Wrap::Type->parse()',          needs_lib => 1 },
            grammar  => { script => 'fuzz_grammar_mutate.pl', desc => 'Grammar-aware C sig mutations',       needs_lib => 1, extra_inc => 1 },
            register => { script => 'fuzz_register_types.pl', desc => 'Affix::_typedef() — C parser direct', needs_lib => 1 },
            cross    => { script => 'fuzz_cross_boundary.pl', desc => 'Cross-boundary Perl->C->JIT',         needs_lib => 1 },
            compile  => { script => 'fuzz_compile_ok.pl',     desc => 'compile_ok() C compilation',          needs_lib => 1 },
            shared   => { script => 'fuzz_shared_lib.pl',     desc => 'Compile→load→affix→call→verify ABI',  needs_lib => 1 },
        );

        # C fuzz targets (delegate to infix/build.pl)
        my %c_targets = (
            signature  => 'Parser crashes + arena stress',
            abi        => 'ABI classification',
            types      => 'Type generator bugs',
            roundtrip  => 'Type->String->Type consistency',
            trampoline => 'JIT trampoline creation',
            direct     => 'Direct marshalling JIT',
        );
        my $fuzz_dir = path('fuzz');
        die "fuzz/ directory not found\n" unless -d $fuzz_dir;
        my $failures = 0;
        my $iters    = $args{smoke} ? 100 : $max_iter;
        my $to       = $args{smoke} ? 3   : $timeout;

        # Run Perl fuzz targets via TAP::Harness for proper TAP output
        require TAP::Harness::Env;
        my @fuzz_scripts;
        for my $name (@targets) {
            my $target = $perl_targets{$name} // do { warn "Unknown Perl fuzz target: $name\n"; $failures++; next };
            my $script = $fuzz_dir->child( $target->{script} );
            unless ( -f $script ) {
                warn "Fuzz script not found: $script\n";
                $failures++;
                next;
            }
            say "=" x 60;
            say "Fuzzing: $target->{desc}";
            say "  Script: $target->{script}";
            say "  Iterations: $iters, Timeout: ${to}s";
            say "=" x 60;
            push @fuzz_scripts, $script->stringify;
        }
        if (@fuzz_scripts) {
            local $ENV{FUZZ_MAX_ITER} = $iters;
            local $ENV{FUZZ_TIMEOUT}  = $to;
            local $ENV{FUZZ_VERBOSE}  = $verbose_fuzz;
            my %harness_args
                = ( ( verbosity => $verbose ), ( color => -t STDOUT ), lib => [ map { rel2abs( catdir( 'blib', $_ ) ) } qw[arch lib] ], );
            my $harness = TAP::Harness::Env->create( \%harness_args );
            my $aggr    = $harness->runtests( sort @fuzz_scripts );
            $failures++ if $aggr->has_errors;
            say "";
        }

        # Smoke test: also quick-build C targets if available
        if ( $args{smoke} || $args{all} ) {
            my $build_pl = path('infix/build.pl');
            if ( -f $build_pl ) {
                for my $name ( sort keys %c_targets ) {
                    say "=" x 60;
                    say "Building C fuzz target: fuzz:$name";
                    say "  $c_targets{$name}";
                    say "=" x 60;
                    my $exit = system( $^X, $build_pl->stringify, "fuzz:$name" );
                    $failures++ if $exit != 0;
                    say "";
                }
            }
            else {
                say "Skipping C fuzz targets (infix/build.pl not found)";
            }
        }
        say "=" x 60;
        if ($failures) {
            say "FAILED: $failures target(s) reported crashes or build errors";
        }
        else {
            say "All fuzz targets clean.";
        }
        return $failures > 0 ? 1 : 0;
    }

    method get_arguments (@sources) {
        $_ = detildefy($_) for grep {defined} $install_base, $destdir, $prefix, values %{$install_paths};
        $install_paths = ExtUtils::InstallPaths->new( dist_name => $meta->name );
        return;
    }

    method Build(@args) {
        my $method = $self->can( 'step_' . $action );
        $method // die "No such action '$action'\n";
        exit $method->( $self, @args );
    }

    method Build_PL() {
        die "Pure perl Affix? Ha! You wish.\n" if $pureperl;
        say sprintf 'Creating new Build script for %s %s', $meta->name, $meta->version;
        $self->write_file( 'Build', sprintf <<'', $^X, __PACKAGE__, __PACKAGE__ );
#!%s
use lib 'builder';
use %s;
my $action = @ARGV && $ARGV[0] =~ /\A\w+\z/ ? shift @ARGV : 'build';
my $opts = {};
while ( @ARGV ) {
    my $a = shift @ARGV;
    if ( $a =~ /^-(\w+)$/ ) { $opts->{$1} = shift @ARGV // 1; }
    elsif ( $a =~ /^-(\w+)=(.+)$/ ) { $opts->{$1} = $2; }
}
%s->new( action => $action )->Build( %%$opts );

        make_executable('Build');
        my @env = defined $ENV{PERL_MB_OPT} ? split_like_shell( $ENV{PERL_MB_OPT} ) : ();
        $self->write_file( '_build_params', encode_json( [ \@env, \@ARGV ] ) );
        if ( my $dynamic = $meta->custom('x_dynamic_prereqs') ) {
            my %meta = ( %{ $meta->as_struct }, dynamic_config => 1 );
            $self->get_arguments( \@env, \@ARGV );
            require CPAN::Requirements::Dynamic;
            my $dynamic_parser = CPAN::Requirements::Dynamic->new();
            my $prereq         = $dynamic_parser->evaluate($dynamic);
            $meta{prereqs} = $meta->effective_prereqs->with_merged_prereqs($prereq)->as_string_hash;
            $meta = CPAN::Meta->new( \%meta );
        }
        $meta->save(@$_) for ['MYMETA.json'];
    }

    sub find ( $pattern, $base ) {
        $base = path($base) unless builtin::blessed $base;
        my $blah = $base->visit(
            sub ( $path, $state ) {
                $state->{$path} = $path if $path =~ $pattern;
            },
            { recurse => 1 }
        );
        values %$blah;
    }

builder/Affix/Builder.pm  view on Meta::CPAN

        warn "Checking if -lrt is required...\n" if $verbose;
        my $cc        = $Config{cc} || 'cc';
        my $test_code = <<'END_C';
#include <sys/mman.h>
#include <fcntl.h>
int main(void) { shm_open("/test", O_RDONLY, 0); return 0; }
END_C
        my ( $fh, $src ) = tempfile( SUFFIX => '.c', UNLINK => 1 );
        print $fh $test_code;
        close $fh;
        my ( $ofh, $out ) = tempfile( UNLINK => 1 );
        close $ofh;

        # Try without -lrt (list-form system to avoid shell injection)
        open( my $devnull, '>', '/dev/null' ) if $^O ne 'MSWin32';
        my $old_stdout = select $devnull      if $devnull;
        system( $cc, '-o', $out, $src );
        select $old_stdout if $old_stdout;
        close $devnull     if $devnull;
        return ''          if $? == 0;

        # Try with -lrt
        open( $devnull, '>', '/dev/null' ) if $^O ne 'MSWin32';
        $old_stdout = select $devnull      if $devnull;
        system( $cc, '-o', $out, $src, '-lrt' );
        select $old_stdout if $old_stdout;
        close $devnull     if $devnull;
        return '-lrt'      if $? == 0;
        return '';
    }

    sub command_exists {
        my ($cmd) = @_;
        if ( $Config{osname} eq 'MSWin32' ) {
            return system( 'where', $cmd ) == 0;
        }
        else {
            return system( 'command', '-v', $cmd ) == 0;
        }
    }

    method step_affix {
        $self->step_infix;
        my $cwd = cwd->absolute;
        my @objs;
        require ExtUtils::CBuilder;
        my %config = %Config;
        if ($debug) {
            $config{ldflags}   =~ s/-s //g;
            $config{ldflags}   =~ s/ -s//g;
            $config{lddlflags} =~ s/-s //g;
            $config{lddlflags} =~ s/ -s//g;
        }
        my $builder = ExtUtils::CBuilder->new( quiet => !$verbose, config => \%config );
        my $pre     = $cwd->child(qw[blib arch auto])->absolute;
        require DynaLoader;
        my $mod2fname = defined &DynaLoader::mod2fname ? \&DynaLoader::mod2fname : sub { return $_[0][-1] };
        my @parts     = ('Affix');
        my $archdir   = rel2abs catdir( curdir, qw[. blib arch auto], @parts );
        my $err;
        make_path( $archdir, { chmod => 0755, error => \$err, verbose => $verbose } );
        my $lib_file = catfile( $archdir, $mod2fname->( \@parts ) . '.' . $Config{dlext} );
        my @dirs;
        push @dirs, '../';
        my $has_cxx    = !1;
        my $recompiled = 0;
        my @sources    = $cwd->child('lib/Affix.c');

        #~ warn "Sources to process: @sources\n";
        for my $source (@sources) {

            #~ warn "Processing source: $source\n";
            my $cxx       = $source =~ /cx+$/;
            my $file_base = $source->basename(qr[.c$]);
            my $tempdir   = path('lib');
            $tempdir->mkdir( { verbose => $verbose, mode => oct '755' } );
            my $version = $meta->version;
            my $obj     = $builder->object_file($source);

            #~ warn "Checking obj: $obj\n";
            # Check mtimes of all .c and .h files under lib/ (includes Affix.c, marshal.c, Affix.h)
            my $newest_dep = $source->stat->mtime;
            my $iter       = path('lib')->iterator;
            while ( my $entry = $iter->() ) {
                next unless $entry->is_file;
                next unless $entry =~ /\.[ch]$/;
                my $dep_mtime = $entry->stat->mtime;
                $newest_dep = $dep_mtime if $dep_mtime > $newest_dep;
            }
            my $should_compile
                = ( $force ||
                    ( !-f $obj ) ||
                    ( $newest_dep >= path($obj)->stat->mtime ) ||
                    ( path(__FILE__)->stat->mtime > path($obj)->stat->mtime ) );
            if ($should_compile) {
                my $reason
                    = !-f $obj                                            ? 'object file missing' :
                    $newest_dep >= path($obj)->stat->mtime                ? 'source newer than object' :
                    path(__FILE__)->stat->mtime > path($obj)->stat->mtime ? 'builder changed' :
                    'forced';
                warn "Compiling $source ($reason)\n";
                $recompiled = 1;
            }
            push @dirs, $source->dirname();
            $has_cxx = 1 if $cxx;
            push @objs,
                $should_compile ?
                $builder->compile(
                quiet        => 0,
                'C++'        => $cxx,
                source       => $source->stringify,
                defines      => { VERSION => qq/"$version"/, XS_VERSION => qq/"$version"/ },
                include_dirs => [
                    cwd->stringify,                                             cwd->child('infix')->realpath->stringify,
                    cwd->child('infix')->child('include')->realpath->stringify, cwd->child('infix')->child('src')->realpath->stringify,
                    $source->dirname,                                           $pre->child( $meta->name, 'include' )->stringify
                ],
                extra_compiler_flags =>
                    ( '-fPIC -std=' . ( $cxx ? $cppver : $cver ) . ' ' . $cflags . ( $debug ? ' -ggdb3 -g -Wall -Wextra -pedantic' : '' ) )
                ) :
                $obj;