File Coverage

blib/lib/App/ArchiveDevelCover.pm

Criterion	Covered	Total	%
statement	155	160	96.8
branch	20	26	76.9
condition	6	12	50.0
subroutine	24	24	100.0
pod	0	7	0.0
total	205	229	89.5

use 5.010;
use Moose;
use MooseX::Types::Path::Class;
use DateTime;
use File::Copy;
use HTML::TableExtract;
use experimental qw(switch);

# ABSTRACT: Archive Devel::Cover reports
our $VERSION = '1.004'; # VERSION

with 'MooseX::Getopt';

has [qw(from to)] => (is=>'ro',isa=>'Path::Class::Dir',coerce=>1,required=>1,);
has 'project' => (is => 'ro', isa=>'Str', lazy_build=>1);
    my $self = shift;
    my @list = $self->from->parent->dir_list;
    return $list[-1] || 'unknown project';
}
has 'coverage_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
    my $self = shift;
    if (-e $self->from->file('coverage.html')) {
        return $self->from->file('coverage.html');
    }
    else {
        say "Cannot find 'coverage.html' in ".$self->from.'. Aborting';
        exit;
    }
}
has 'runtime' => (is=>'ro',isa=>'DateTime',lazy_build=>1,traits=> ['NoGetopt'],);
    my $self = shift;
    return DateTime->from_epoch(epoch=>$self->coverage_html->stat->mtime);
}
has 'archive_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
    my $self = shift;
    unless (-e $self->to->file('index.html')) {
        my $tpl = $self->_archive_template;
        my $fh = $self->to->file('index.html')->openw;
        print $fh $tpl;
        close $fh;
    }
    return $self->to->file('index.html');
}
has 'archive_db' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
    my $self = shift;
    return $self->to->file('archive_db');
}
has 'previous_stats' => (is=>'ro',isa=>'ArrayRef',lazy_build=>1,traits=>['NoGetopt']);
    my $self = shift;
    if (-e $self->archive_db) {
        my $dbr = $self->archive_db->openr;
        my @data = <$dbr>; # probably better to just get last line...
        my @prev = split(/;/,$data[-1]);
        return \@prev;
    }
    else {
        return [undef,0,0,0];
    }
}
has 'diff_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
    my $self = shift;
    return $self->to->subdir($self->runtime->iso8601)->file('diff.html');
}

    my $self = shift;
    $self->archive;
    $self->generate_diff;
    $self->update_index;
}

    my $self = shift;

    my $from = $self->from;
    my $target = $self->to->subdir($self->runtime->iso8601);

    if (-e $target) {
        say "This coverage report has already been archived.";
        exit;
    }

    $target->mkpath;
    my $target_string = $target->stringify;

    while (my $f = $from->next) {
        next unless $f=~/\.(html|css)$/;
        copy($f->stringify,$target_string) || die "Cannot copy $from to $target_string: $!";
    }

    say "archived coverage reports at $target_string";
}

    my $self = shift;

    my $te = HTML::TableExtract->new( headers => [qw(stm sub total)] );
    $te->parse(scalar $self->coverage_html->slurp);
    my $rows =$te->rows;
    my $last_row = $rows->[-1];

    $self->update_archive_html($last_row);
    $self->update_archive_db($last_row);
}

    my ($self, $last_row) = @_;

    my $prev_stats = $self->previous_stats;
    my $runtime = $self->runtime;
    my $date = $runtime->ymd('-').' '.$runtime->hms;
    my $link = "./".$runtime->iso8601."/coverage.html";
    my $diff = "./".$runtime->iso8601."/diff.html";

    my $new_stat = qq{\n<tr><td><a href="$link">$date</a></td><td><a href="$diff">diff</a></td>};
    foreach my $val (@$last_row) {
        $new_stat.=$self->td_style($val);
    }
    my $prev_total = $prev_stats->[3];
    my $this_total = $last_row->[-1];
    if ($this_total == $prev_total) {
        $new_stat.=qq{<td class="c3">=</td>};
    }
    elsif ($this_total > $prev_total) {
        $new_stat.=qq{<td class="c3">+</td>};
    }
    else {
        $new_stat.=qq{<td class="c0">-</td>};
    }

    $new_stat.="</tr>\n";

    my $archive = $self->archive_html->slurp;
    $archive =~ s/(<!-- INSERT -->)/$1 . $new_stat/e;

    my $fh = $self->archive_html->openw;
    print $fh $archive;
    close $fh;

    unless (-e $self->to->file('cover.css')) {
         copy($self->from->file('cover.css'),$self->to->file('cover.css')) || warn "Cannot copy cover.css: $!";
    }
}

    my ($self, $last_row) = @_;
    my $dbw = $self->archive_db->open(">>") || warn "Can't write archive.db: $!";
    say $dbw join(';',$self->runtime->iso8601,@$last_row);
    close $dbw;
}

    my $self = shift;

    my $prev = $self->previous_stats;
    return unless $prev->[0];

    my $te_new = HTML::TableExtract->new( headers => [qw(file stm sub total)] );
    $te_new->parse(scalar $self->coverage_html->slurp);
    my $new_rows =$te_new->rows;
    my $te_old = HTML::TableExtract->new( headers => [qw(file stm sub total)] );
    $te_old->parse(scalar $self->to->subdir($prev->[0])->file('coverage.html')->slurp);
    my $old_rows =$te_old->rows;

    my %diff;
    foreach my $row (@$new_rows) {
        my $file =shift(@$row);
        $diff{$file}=$row;
    }

    foreach my $row (@$old_rows) {
        my $file =shift(@$row);
        push(@{$diff{$file}},@$row);
    }

    my @output;
    foreach my $file (sort keys %diff) {
        my $data = $diff{$file};

        my $line = qq{\n<tr><td>$file</td>};
        foreach my $i (0,1,2) {
            my $nv = $data->[$i] || 0;
            my $ov = $data->[$i+3] || 0;
            my $display = "$ov&nbsp;-&gt;&nbsp;$nv";
            if ($nv == $ov) {
                $line.=qq{<td>$display</td>};
            }
            elsif ($nv > $ov) {
                $line.=$self->td_style(100,$display);
            }
            else {
                $line.=$self->td_style(0,$display);
            }
        }
        $line.="</tr>";
        push(@output,$line);
    }
    my $table = join("\n",@output);
    my $tpl = $self->_diff_template;
    $tpl=~s/DATA/$table/;

    my $fh = $self->diff_html->openw;
    print $fh $tpl;
    close $fh;
}

    my ($self, $val, $display) = @_;
    $display //=$val;
    my $style;
    given ($val) {
        when ($_ <  75) { $style = 'c0' }
        when ($_ <  90) { $style = 'c1' }
        when ($_ <  100) { $style = 'c2' }
        when ($_ >= 100) { $style = 'c3' }
    }
    return qq{<td class="$style">$display</td>};
}

    my $self = shift;
    my $name = $self->project;
    $self->_page_template(
        "Test Coverage Archive for $name",
        q{
<table>
<tr><th>Coverage Report</th><th>diff</th><th>stmt</th><th>sub</th><th>total</th><th>Trend</th></tr>
<!-- INSERT -->
</table>
                });
}

    my $self = shift;
    my $name = $self->project;
    $self->_page_template(
        "Test Coverage Diff for $name",
        q{
<table>
<tr><th>File</th><th>stmt</th><th>sub</th><th>total</th></tr>
DATA
</table>
                });
}

    my ($self, $title, $content) = @_;

    my $name = $self->project;
    my $class = ref($self);
    my $version = $class->VERSION;
    return <<"EOTMPL";
<!DOCTYPE html
     PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<!-- This file was generated by $class version $version -->
<head>
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8"></meta>
    <meta http-equiv="Content-Language" content="en-us"></meta>
    <link rel="stylesheet" type="text/css" href="cover.css"></link>
    <title>Test Coverage Archive for $name</title>
</head>
<body>

<body>
<h1>$title</h1>

$content

<p>Generated by <a href="http://metacpan.org/module/$class">$class</a> version $version.</p>

</body>
</html>
EOTMPL

}

__PACKAGE__->meta->make_immutable;
1;


=pod

=encoding UTF-8

=head1 NAME

App::ArchiveDevelCover - Archive Devel::Cover reports

=head1 VERSION

version 1.004

=head1 SYNOPSIS

Backend for the C<archive_devel_cover.pl> command. See L<archive_devel_cover.pl> and/or C<perldoc archive_devel_cover.pl> for details.

=head1 AUTHOR

Thomas Klausner <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 - 2022 by Thomas Klausner.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut