File Coverage

File:lib/App/ArchiveDevelCover.pm
Coverage:18.5%

linestmtbrancondsubtimecode
1package App::ArchiveDevelCover;
2
1
1
1
1
1
1
65861
5
33
5
3
77
use 5.010;
3
1
1
1
472
391002
12
use Moose;
4
1
1
1
42126
352675
23
use MooseX::Types::Path::Class;
5
1
1
1
1208
211378
23
use DateTime;
6
1
1
1
5703
1806
49
use File::Copy;
7
1
1
1
12219
17043
9
use HTML::TableExtract;
8
9# ABSTRACT: Archive Devel::Cover reports
10our $VERSION = '1.000';
11
12with 'MooseX::Getopt';
13
14has [qw(from to)] => (is=>'ro',isa=>'Path::Class::Dir',coerce=>1,required=>1,);
15has 'project' => (is => 'ro', isa=>'Str');
16has 'coverage_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
17sub _build_coverage_html {
18
0
    my $self = shift;
19
0
    if (-e $self->from->file('coverage.html')) {
20
0
        return $self->from->file('coverage.html');
21    }
22    else {
23
0
        say "Cannot find 'coverage.html' in ".$self->from.'. Aborting';
24
0
        exit;
25    }
26}
27has 'runtime' => (is=>'ro',isa=>'DateTime',lazy_build=>1,traits=> ['NoGetopt'],);
28sub _build_runtime {
29
0
    my $self = shift;
30
0
    return DateTime->from_epoch(epoch=>$self->coverage_html->stat->mtime);
31}
32has 'archive_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
33sub _build_archive_html {
34
0
    my $self = shift;
35
0
    unless (-e $self->to->file('index.html')) {
36
0
        my $tpl = $self->_archive_template;
37
0
        my $fh = $self->to->file('index.html')->openw;
38
0
        print $fh $tpl;
39
0
        close $fh;
40    }
41
0
    return $self->to->file('index.html');
42}
43has 'archive_db' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
44sub _build_archive_db {
45
0
    my $self = shift;
46
0
    return $self->to->file('archive_db');
47}
48has 'previous_stats' => (is=>'ro',isa=>'ArrayRef',lazy_build=>1,traits=>['NoGetopt']);
49sub _build_previous_stats {
50
0
    my $self = shift;
51
0
    if (-e $self->archive_db) {
52
0
        my $dbr = $self->archive_db->openr;
53
0
        my @data = <$dbr>; # probably better to just get last line...
54
0
        my @prev = split(/;/,$data[-1]);
55
0
        return \@prev;
56    }
57    else {
58
0
        return [undef,0,0,0];
59    }
60}
61
62sub run {
63
0
    my $self = shift;
64
0
    $self->archive;
65
0
    $self->update_index;
66}
67
68sub archive {
69
0
    my $self = shift;
70
71
0
    my $from = $self->from;
72
0
    my $target = $self->to->subdir($self->runtime->iso8601);
73
74
0
    if (-e $target) {
75
0
        say "This coverage report has already been archived.";
76
0
        exit;
77    }
78
79
0
    $target->mkpath;
80
0
    my $target_string = $target->stringify;
81
82
0
    while (my $f = $from->next) {
83
0
        next unless $f=~/\.(html|css)$/;
84
0
        copy($f->stringify,$target_string) || die "Cannot copy $from to $target_string: $!";
85    }
86
87
0
    say "archived coverage reports at $target_string";
88}
89
90sub update_index {
91
0
    my $self = shift;
92
93
0
    my $te = HTML::TableExtract->new( headers => [qw(stm sub total)] );
94
0
    $te->parse(scalar $self->coverage_html->slurp);
95
0
    my $rows =$te->rows;
96
0
    my $last_row = $rows->[-1];
97
98
0
    $self->update_archive_html($last_row);
99
0
    $self->update_archive_db($last_row);
100}
101
102sub update_archive_html {
103
0
    my ($self, $last_row) = @_;
104
105
0
    my $prev_stats = $self->previous_stats;
106
0
    my $runtime = $self->runtime;
107
0
    my $date = $runtime->ymd('-').' '.$runtime->hms;
108
0
    my $link = $runtime->iso8601."/coverage.html";
109
110
0
    my $new_stat = qq{\n<tr><td><a href="$link">$date</a></td>};
111
0
    foreach my $val (@$last_row) {
112
0
        my $style;
113
0
        given ($val) {
114
0
0
            when ($_ < 75) { $style = 'c0' }
115
0
0
            when ($_ < 90) { $style = 'c1' }
116
0
0
            when ($_ < 100) { $style = 'c2' }
117
0
0
            when ($_ >= 100) { $style = 'c3' }
118        }
119
0
        $new_stat.=qq{<td class="$style">$val</td>};
120    }
121
0
    my $prev_total = $prev_stats->[3];
122
0
    my $this_total = $last_row->[-1];
123
0
    if ($this_total == $prev_total) {
124
0
        $new_stat.=qq{<td class="c3">=</td>};
125    }
126    elsif ($this_total > $prev_total) {
127
0
        $new_stat.=qq{<td class="c3">+</td>};
128    }
129    else {
130
0
        $new_stat.=qq{<td class="c0">-</td>};
131    }
132
133
0
    $new_stat.="</tr>\n";
134
135
0
    my $archive = $self->archive_html->slurp;
136
0
0
    $archive =~ s/(<!-- INSERT -->)/$1 . $new_stat/e;
137
138
0
    my $fh = $self->archive_html->openw;
139
0
    print $fh $archive;
140
0
    close $fh;
141
142
0
    unless (-e $self->to->file('cover.css')) {
143
0
         copy($self->from->file('cover.css'),$self->to->file('cover.css')) || warn "Cannot copy cover.css: $!";
144    }
145}
146
147sub update_archive_db {
148
0
    my ($self, $last_row) = @_;
149
0
    my $dbw = $self->archive_db->open(">>") || warn "Can't write archive.db: $!";
150
0
    say $dbw join(';',$self->runtime->iso8601,@$last_row);
151
0
    close $dbw;
152}
153
154sub _archive_template {
155
0
    my $self = shift;
156
0
    my $name = $self->project || 'unnamed project';
157
0
    my $class = ref($self);
158
0
    my $version = $class->VERSION;
159
0
    return <<"EOTMPL";
160<!DOCTYPE html
161     PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
162     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
163<html xmlns="http://www.w3.org/1999/xhtml">
164<!-- This file was generated by $class version $version -->
165<head>
166    <meta http-equiv="Content-Type" content="text/html; charset=utf-8"></meta>
167    <meta http-equiv="Content-Language" content="en-us"></meta>
168    <link rel="stylesheet" type="text/css" href="cover.css"></link>
169    <title>Test Coverage Archive for $name</title>
170</head>
171<body>
172
173<body>
174<h1>Test Coverage Archive for $name</h1>
175
176<table>
177<tr><th>Coverage Report</th><th>stmt</th><th>sub</th><th>total</th><th>Trend</th></tr>
178<!-- INSERT -->
179</table>
180
181<p>Generated by <a href="http://metacpan.org/module/$class">$class</a> version $version.</p>
182
183</body>
184</html>
185EOTMPL
186}
187
188__PACKAGE__->meta->make_immutable;
1891;
190