view release on metacpan or  search on metacpan

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

        return () if $exclude->subsumes($path);
    }

    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 consider 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} = {};
        my %seen;

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

            my $key = $SPECIAL_SUBS{$sub} ? '*' : $sub;
            push @{$oval->{$key}} => grep { !$seen{$key}{_from_key($_)}++ } values %{$rval->{$sub}};
        }

        @$_ = sort { _from_key($a) cmp _from_key($b) } @$_ for values %$oval;
    }

    return $out;
}

# Sort/dedup key for 'from' values. References are keyed by serialized
# content, not address, so output order is stable between runs and
# identical structures from separate set_from() calls collapse into one.
sub _from_key {
    my ($val) = @_;
    return "s:$val" unless ref $val;

    require Data::Dumper;
    local $Data::Dumper::Indent   = 0;
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Terse    = 1;

    return "r:" . Data::Dumper::Dumper($val);
}

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';