view release on metacpan or  search on metacpan

lib/Test2/Tools/Affix.pm  view on Meta::CPAN

            $c->release;
            return ();
        }
        $aggs->{cflags} .= ' -I' . $Inc;
        my $compiler = Affix::Build->new( debug => 0, name => 'testing', version => '1.0', flags => $aggs );
        $compiler->add( $opt->canonpath );
        $compiler->link;
        push @cleanup, $opt->canonpath, $compiler->link unless $keep;
        $c->ok( 1, 'build lib: ' . $compiler->link );
        $c->release;
        $compiler->link;
    }

    sub affix_ok ( $lib, $name, $args, $ret ) {
        my $c = context;
        my $sub;
        diag __PACKAGE__;
        diag join ', ', caller;
        my $okay = run_subtest(
            'affix ' . $name . '( ... )',
            sub {
                ok lives {
                    $sub = affix( $lib, $name, $args, $ret )
                }, 'affix ' . $name . ' ...';
                isa_ok $sub, ['Affix'], $name;
            },
            { buffered => 0, no_fork => 1 }
        );
        $c->release;
        return $sub;
    }
    {
        my $supp;    # defined later
        my ( $test, $generate_suppressions, $count );
        my $valgrind = 0;
        my $file;

        sub init_valgrind {
            return if $valgrind;
            require Path::Tiny;
            $file     = Path::Tiny::path($0)->absolute;
            $valgrind = 1;
            return plan skip_all 'Capture::Tiny is not installed' unless eval 'require Capture::Tiny';
            return plan skip_all 'Path::Tiny is not installed'    unless eval 'require Path::Tiny';
            require Getopt::Long;
            Getopt::Long::GetOptions( 'test=s' => \$test, 'generate' => \$generate_suppressions, 'count=i' => \$count );
            Test2::API::test2_stack()->top->{count} = $count if defined $count;

            if ( defined $test ) {

                #~ Affix::set_destruct_level(3);
                #~ die 'I should be running a test named ' . $test;
            }
            elsif ( defined $generate_suppressions ) {
                no Test2::Plugin::ExitSummary;
                pass 'exiting...';
                done_testing;
                exit;
            }
            else {
                my ( $stdout, $stderr, $exit_code ) = Capture::Tiny::capture(
                    sub {
                        system('valgrind --version');
                    }
                );
                plan skip_all 'Valgrind is not installed' if $exit_code;
                diag 'Valgrind v', ( $stdout =~ m/valgrind-(.+)$/ ), ' found';
                diag 'Generating suppressions...';
                my @cmd = (
                    qw[valgrind --leak-check=full --show-reachable=yes --error-limit=no
                        --gen-suppressions=all --log-fd=1], $^X, '-e',
                    sprintf <<'', ( join ', ', map {"'$_'"} sort { length $a <=> length $b } map { path($_)->absolute->canonpath } @INC ) );
    use strict;
    use warnings;
    use lib %s;
    use Affix;
    no Test2::Plugin::ExitSummary;
    use Test2::V0;
    pass "generate valgrind suppressions";
    done_testing;


                #~ use Data::Dump;
                #~ ddx \@cmd;
                my ( $out, $err, @res ) = Capture::Tiny::capture(
                    sub {
                        system @cmd;
                    }
                );
                my ( $known, $dups ) = parse_suppression($out);

                #~ diag $out;
                #~ diag $err;
                diag scalar( keys %$known ) . ' suppressions found';
                diag $dups . ' duplicates have been filtered out';
                $known->{'BSD is trash'} = <<'';
{
    <insert_a_suppression_name_here>
    Memcheck:Free
    fun:~vector
}

                $known->{'chaotic access'} = <<'';
{
    <insert_a_suppression_name_here>
    Memcheck:Addr1
    fun:_DumpHex
}


                # https://bugs.kde.org/show_bug.cgi?id=453084
                # https://github.com/Perl/perl5/issues/19949
                # https://github.com/Perl/perl5/issues/20970
                $known->{'https://github.com/Perl/perl5/issues/19949'} = <<'';
{
   <insert_a_suppression_name_here>
   Memcheck:Overlap
   fun:__memcpy_chk
   fun:XS_Cwd_abs_path
   fun:Perl_pp_entersub
   fun:Perl_runops_standard