File Coverage

blib/lib/Test2/Plugin/Cover.pm

Criterion	Covered	Total	%
statement	143	162	88.2
branch	54	74	72.9
condition	16	30	53.3
subroutine	27	33	81.8
pod	18	20	90.0
total	258	319	80.8

package Test2::Plugin::Cover;
use strict;
use warnings;

use Test2::API qw/test2_add_callback_exit context/;
use Path::Tiny qw/path/;
use Storable qw/dclone/;
use Carp qw/croak/;
use File::Spec();

my $SEP = File::Spec->catfile('', '');

our $VERSION = '0.000027';

# Directly modifying this is a bad idea, but for the XS to work it needs to be
# a package var, not a lexical.
our $FROM = '*';
my $FROM_MODIFIED = 0;
my $FROM_MANAGER;

our ($ENABLED, $ROOT, $LOAD_ROOT, %REPORT, @OPENS, $TRACE_OPENS);
BEGIN {
    $TRACE_OPENS = 0;
    $ENABLED = 0;
    $LOAD_ROOT = "" . path('.')->realpath;
    $ROOT = $LOAD_ROOT;
}

my %FILTER;

use XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);

1;

my $IMPORTED = 0;
sub import {
    my $class = shift;
    my %params = @_;

    if ($params{disabled}) {
        $class->disable;
        return;
    }

    $class->enable;

    return if $params{no_event};

    if ($IMPORTED++) {
        croak "$class has already been imported, too late to add params" if keys %params;
        return;
    }

    $class->reload;

    my $ran = 0;
    $ROOT = "" . $params{root} if $params{root};
    my $callback = sub { return if $ran++; $class->report(%params, ctx => $_[0], root => $ROOT) };

    test2_add_callback_exit($callback);

    # Fallback if we fork.
    eval 'END { local $?; $callback->() }; 1' or die $@;
}

sub reload {
    $ROOT = $LOAD_ROOT // "" . path('.')->realpath;
    %FILTER = map {-f $_ ? ($_ => 1) : ()} $0, __FILE__, File::Spec->rel2abs($0), File::Spec->rel2abs(__FILE__);
}

sub enabled { $ENABLED }
sub enable  { $ENABLED = 1 }
sub disable { $ENABLED = 0 }

sub full_reset {
    reset_from();
    reset_coverage();
}

sub reset_from {
    $FROM = '*';
    $FROM_MODIFIED = 0;
    $FROM_MANAGER = undef;
}

sub reset_coverage {
    %REPORT  = ();
}

sub set_root { $ROOT = "" . pop };

sub get_from   { $FROM //= '*' }
sub set_from   { $FROM_MODIFIED++; $FROM = pop }
sub clear_from { $FROM = '*' }
sub was_from_modified { $FROM_MODIFIED ? 1 : 0 }
sub set_from_manager  { $FROM_MODIFIED++; $FROM_MANAGER = pop }

sub touch_data_file {
    my $class = shift;
    my ($file, $from) = @_;
    croak "A file is required" unless $file;
    $from //= $FROM;

    $REPORT{$file}{'<>'}{$from} = $from;
    return;
}

sub touch_source_file {
    my $class = shift;
    my ($file, $subs, $from) = @_;
    croak "A file is required" unless $file;

    $subs //= ['*'];
    $subs = [$subs] unless 'ARRAY' eq ref($subs);

    $from //= $FROM;

    $REPORT{$file}{$_}{$from} = $from for @$subs;

    return;
}

sub filter {
    my $class = shift;
    my ($file, %params) = @_;

    my $root = $params{root} // path('.')->realpath;
    $root = path($root);

    my $path = $INC{$file} ? path($INC{$file}) : path($file);
    $path = $path->realpath if $path->exists;

    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,
        },

        info => [{tag => 'COVERAGE', details => $details, debug => $params{verbose}}],
    );
    $ctx->release unless $params{ctx};

    return $event;
}

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

    my $filter  = $class->can('filter');
    my $extract = $class->can('extract');

    my $clone = dclone(\%REPORT);
    my %report;

    for my $raw (keys %$clone) {
        next unless $raw;
        next if $FILTER{$raw};

        my $file = $class->$extract($raw, %params) // next;
        next if $FILTER{$file};

        my $path = $class->$filter($file, %params) // next;
        next if $FILTER{$path};

        my $from = $clone->{$raw};

        # Merge
        my $into = $report{$path} //= {};

        for my $sub (keys %$from) {
            if ($into->{$sub}) {
                $into->{$sub} = {%{dclone($into->{$sub})}, %{$from->{$sub}}};
            }
            else {
                $into->{$sub} = dclone($from->{$sub}) if $from->{$sub};
            }
        }
    }

    return \%report;
}

1;

__END__