view release on metacpan or  search on metacpan

lib/Test2/Plugin/Cover.pm  view on Meta::CPAN

    return () unless $root->subsumes($file);

    return $path->relative($root)->stringify();
}

sub extract {
    my $class = shift;
    my ($file) = @_;

    # If we opened a file with 2-arg open
    $file =~ s/^[\+\-]?(?:>{1,2}|<|\|)[\+\-]?//;

    # Sometimes things get nested and we need to extract and then extract again...
    while (1) {
        # No hope :-(
        return if $file =~ m/^\(eval( \d+\)?)$/;

        # Easy
        return $file if -e $file;

        my $start = $file;

        # Moose like to write "blah blah (defined at filename line 123)"
        $file = $1 if $file =~ m/(?:defined|declared) (?:at|in) (.+) at line \d+/;
        $file = $1 if $file =~ m/(?:defined|declared) (?:at|in) (.+) line \d+/;
        $file = $1 if $file =~ m/\(eval \d+\)\[(.+):\d+\]/;
        $file = $1 if $file =~ m/\((.+)\) line \d+/;
        $file = $1 if $file =~ m/\((.+)\) at line \d+/;

        # Extracted everything away
        return unless $file;

        # Not going to change anymore
        last if $file eq $start;
    }

    # These characters are rare in file names, but common in calls where files
    # could not be determined, so we probably failed to extract. If this
    # assumption is wrong for someone they can write a custom extract, this is
    # not a bug.
    return if $file =~ m/([\[\]\(\)]|->|\beval\b)/;

    # If we have a foo.bar pattern, or a string that contains this platforms
    # file separator we will condifer it a valid file.
    return $file if $file =~ m/\S+\.\S+$/i || $file =~ m/\Q$SEP\E/;

    return;
}

my %HIDDEN_SUBS = (
    '__ANON__'  => 1,
    'eval'      => 1,
);

my %SPECIAL_SUBS = (
    'BEGIN'     => 1,
    'CHECK'     => 1,
    'END'       => 1,
    'INIT'      => 1,
    'UNITCHECK' => 1,
);

sub files {
    my $class = shift;
    my %params = @_;

    my $report = $class->_process(%params);

    return [sort keys %$report];
}

sub data {
    my $class = shift;
    my %params = @_;

    my $report = $class->_process(%params);

    my $out = {};

    for my $file (keys %$report) {
        my $rval = $report->{$file} // next;
        my $oval = $out->{$file} = {};

        for my $sub (keys %$rval) {
            next if $HIDDEN_SUBS{$sub};

            my $key = $SPECIAL_SUBS{$sub} ? '*' : $sub;
            my @add = map { $rval->{$sub}->{$_} } keys %{$rval->{$sub}};

            if ($oval->{$key}) {
                my %seen;
                $oval->{$key} = [ sort grep { !$seen{$_}++ } @{$oval->{$key}}, @add ];
            }
            else {
                $oval->{$key} = [ sort @add ];
            }
        }
    }

    return $out;
}

sub report {
    my $class = shift;
    my %params = @_;

    my $data    = $class->data(%params);
    my $details = "This test covered " . scalar(keys %$data) . " source files.";
    my $type    = $FROM_MODIFIED ? 'split' : 'flat';

    my $ctx   = $params{ctx} // context();
    my $event = $ctx->send_ev2(
        about => {package => __PACKAGE__, details => $details},

        coverage => {
            files        => $data,
            details      => $details,
            test_type    => $type,
            from_manager => $FROM_MANAGER,
        },