File Coverage

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

linestmtbrancondsubtimecode
1package App::ArchiveDevelCover;
2
3
3
3
3
3
3
251193
12
64
13
6
164
use 5.010;
3
3
3
3
891
936193
31
use Moose;
4
3
3
3
16464
863849
33
use MooseX::Types::Path::Class;
5
3
3
3
3602
331604
77
use DateTime;
6
3
3
3
288
1873
160
use File::Copy;
7
3
3
3
1089
35071
28
use HTML::TableExtract;
8
9# ABSTRACT: Archive Devel::Cover reports
10our $VERSION = '1.001';
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', lazy_build=>1);
16sub _build_project {
17
2
28
    my $self = shift;
18
2
15
    my @list = $self->from->parent->dir_list;
19
2
621
    return $list[-1] || 'unknown project';
20}
21has 'coverage_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
22sub _build_coverage_html {
23
4
78
    my $self = shift;
24
4
28
    if (-e $self->from->file('coverage.html')) {
25
3
997
        return $self->from->file('coverage.html');
26    }
27    else {
28
1
344
        say "Cannot find 'coverage.html' in ".$self->from.'. Aborting';
29
1
53
        exit;
30    }
31}
32has 'runtime' => (is=>'ro',isa=>'DateTime',lazy_build=>1,traits=> ['NoGetopt'],);
33sub _build_runtime {
34
4
82
    my $self = shift;
35
4
34
    return DateTime->from_epoch(epoch=>$self->coverage_html->stat->mtime);
36}
37has 'archive_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
38sub _build_archive_html {
39
2
23
    my $self = shift;
40
2
18
    unless (-e $self->to->file('index.html')) {
41
1
340
        my $tpl = $self->_archive_template;
42
1
8
        my $fh = $self->to->file('index.html')->openw;
43
1
456
        print $fh $tpl;
44
1
13
        close $fh;
45    }
46
2
342
    return $self->to->file('index.html');
47}
48has 'archive_db' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
49sub _build_archive_db {
50
2
24
    my $self = shift;
51
2
14
    return $self->to->file('archive_db');
52}
53has 'previous_stats' => (is=>'ro',isa=>'ArrayRef',lazy_build=>1,traits=>['NoGetopt']);
54sub _build_previous_stats {
55
2
27
    my $self = shift;
56
2
16
    if (-e $self->archive_db) {
57
1
359
        my $dbr = $self->archive_db->openr;
58
1
180
        my @data = <$dbr>; # probably better to just get last line...
59
1
4
        my @prev = split(/;/,$data[-1]);
60
1
12
        return \@prev;
61    }
62    else {
63
1
346
        return [undef,0,0,0];
64    }
65}
66has 'diff_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']);
67sub _build_diff_html {
68
1
13
    my $self = shift;
69
1
7
    return $self->to->subdir($self->runtime->iso8601)->file('diff.html');
70}
71
72sub run {
73
4
471948
    my $self = shift;
74
4
21
    $self->archive;
75
2
10
    $self->generate_diff;
76
2
7
    $self->update_index;
77}
78
79sub archive {
80
4
10
    my $self = shift;
81
82
4
33
    my $from = $self->from;
83
4
54
    my $target = $self->to->subdir($self->runtime->iso8601);
84
85
3
3349
    if (-e $target) {
86
1
45
        say "This coverage report has already been archived.";
87
1
9
        exit;
88    }
89
90
2
74
    $target->mkpath;
91
2
237
    my $target_string = $target->stringify;
92
93
2
61
    while (my $f = $from->next) {
94
22
11340
        next unless $f=~/\.(html|css)$/;
95
12
575
        copy($f->stringify,$target_string) || die "Cannot copy $from to $target_string: $!";
96    }
97
98
2
535
    say "archived coverage reports at $target_string";
99}
100
101sub update_index {
102
2
5
    my $self = shift;
103
104
2
22
    my $te = HTML::TableExtract->new( headers => [qw(stm sub total)] );
105
2
256
    $te->parse(scalar $self->coverage_html->slurp);
106
2
6101
    my $rows =$te->rows;
107
2
272
    my $last_row = $rows->[-1];
108
109
2
6
    $self->update_archive_html($last_row);
110
2
1440
    $self->update_archive_db($last_row);
111}
112
113sub update_archive_html {
114
2
5
    my ($self, $last_row) = @_;
115
116
2
15
    my $prev_stats = $self->previous_stats;
117
2
26
    my $runtime = $self->runtime;
118
2
26
    my $date = $runtime->ymd('-').' '.$runtime->hms;
119
2
44
    my $link = $runtime->iso8601."/coverage.html";
120
2
40
    my $diff = $runtime->iso8601."/diff.html";
121
122
2
32
    my $new_stat = qq{\n<tr><td><a href="$link">$date</a></td><td><a href="$diff">diff</a></td>};
123
2
6
    foreach my $val (@$last_row) {
124
6
15
        $new_stat.=$self->td_style($val);
125    }
126
2
5
    my $prev_total = $prev_stats->[3];
127
2
5
    my $this_total = $last_row->[-1];
128
2
16
    if ($this_total == $prev_total) {
129
0
0
        $new_stat.=qq{<td class="c3">=</td>};
130    }
131    elsif ($this_total > $prev_total) {
132
2
5
        $new_stat.=qq{<td class="c3">+</td>};
133    }
134    else {
135
0
0
        $new_stat.=qq{<td class="c0">-</td>};
136    }
137
138
2
4
    $new_stat.="</tr>\n";
139
140
2
19
    my $archive = $self->archive_html->slurp;
141
2
2
915
10
    $archive =~ s/(<!-- INSERT -->)/$1 . $new_stat/e;
142
143
2
15
    my $fh = $self->archive_html->openw;
144
2
336
    print $fh $archive;
145
2
18
    close $fh;
146
147
2
17
    unless (-e $self->to->file('cover.css')) {
148
1
329
         copy($self->from->file('cover.css'),$self->to->file('cover.css')) || warn "Cannot copy cover.css: $!";
149    }
150}
151
152sub update_archive_db {
153
2
5
    my ($self, $last_row) = @_;
154
2
16
    my $dbw = $self->archive_db->open(">>") || warn "Can't write archive.db: $!";
155
2
319
    say $dbw join(';',$self->runtime->iso8601,@$last_row);
156
2
148
    close $dbw;
157}
158
159sub generate_diff {
160
2
5
    my $self = shift;
161
162
2
20
    my $prev = $self->previous_stats;
163
2
25
    return unless $prev->[0];
164
165
1
14
    my $te_new = HTML::TableExtract->new( headers => [qw(file stm sub total)] );
166
1
121
    $te_new->parse(scalar $self->coverage_html->slurp);
167
1
3187
    my $new_rows =$te_new->rows;
168
1
181
    my $te_old = HTML::TableExtract->new( headers => [qw(file stm sub total)] );
169
1
98
    $te_old->parse(scalar $self->to->subdir($prev->[0])->file('coverage.html')->slurp);
170
1
3600
    my $old_rows =$te_old->rows;
171
172
1
137
    my %diff;
173
1
3
    foreach my $row (@$new_rows) {
174
2
5
        my $file =shift(@$row);
175
2
7
        $diff{$file}=$row;
176    }
177
178
1
2
    foreach my $row (@$old_rows) {
179
2
5
        my $file =shift(@$row);
180
2
2
5
6
        push(@{$diff{$file}},@$row);
181    }
182
183
1
2
    my @output;
184
1
4
    foreach my $file (sort keys %diff) {
185
2
5
        my $data = $diff{$file};
186
187
2
5
        my $line = qq{\n<tr><td>$file</td>};
188
2
5
        foreach my $i (0,1,2) {
189
6
17
            my $nv = $data->[$i] || 0;
190
6
17
            my $ov = $data->[$i+3] || 0;
191
6
13
            my $display = "$ov&nbsp;-&gt;&nbsp;$nv";
192
6
20
            if ($nv == $ov) {
193
0
0
                $line.=qq{<td>$display</td>};
194            }
195            elsif ($nv > $ov) {
196
6
16
                $line.=$self->td_style(100,$display);
197            }
198            else {
199
0
0
                $line.=$self->td_style(0,$display);
200            }
201        }
202
2
5
        $line.="</tr>";
203
2
5
        push(@output,$line);
204    }
205
1
4
    my $table = join("\n",@output);
206
1
4
    my $tpl = $self->_diff_template;
207
1
12
    $tpl=~s/DATA/$table/;
208
209
1
9
    my $fh = $self->diff_html->openw;
210
1
719
    print $fh $tpl;
211
1
68
    close $fh;
212}
213
214sub td_style {
215
12
29
    my ($self, $val, $display) = @_;
216
12
29
    $display //=$val;
217
12
22
    my $style;
218
12
24
    given ($val) {
219
12
3
29
7
        when ($_ < 75) { $style = 'c0' }
220
9
2
17
5
        when ($_ < 90) { $style = 'c1' }
221
7
0
12
0
        when ($_ < 100) { $style = 'c2' }
222
7
7
15
15
        when ($_ >= 100) { $style = 'c3' }
223    }
224
12
38
    return qq{<td class="$style">$display</td>};
225}
226
227sub _archive_template {
228
1
2
    my $self = shift;
229
1
8
    my $name = $self->project;
230
1
16
    $self->_page_template(
231        "Test Coverage Archive for $name",
232        q{
233<table>
234<tr><th>Coverage Report</th><th>diff</th><th>stmt</th><th>sub</th><th>total</th><th>Trend</th></tr>
235<!-- INSERT -->
236</table>
237        });
238}
239
240sub _diff_template {
241
1
3
    my $self = shift;
242
1
9
    my $name = $self->project;
243
1
15
    $self->_page_template(
244        "Test Coverage Diff for $name",
245        q{
246<table>
247<tr><th>File</th><th>stmt</th><th>sub</th><th>total</th></tr>
248DATA
249</table>
250        });
251}
252
253sub _page_template {
254
2
6
    my ($self, $title, $content) = @_;
255
256
2
13
    my $name = $self->project;
257
2
17
    my $class = ref($self);
258
2
28
    my $version = $class->VERSION;
259
2
18
    return <<"EOTMPL";
260<!DOCTYPE html
261     PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
262     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
263<html xmlns="http://www.w3.org/1999/xhtml">
264<!-- This file was generated by $class version $version -->
265<head>
266    <meta http-equiv="Content-Type" content="text/html; charset=utf-8"></meta>
267    <meta http-equiv="Content-Language" content="en-us"></meta>
268    <link rel="stylesheet" type="text/css" href="cover.css"></link>
269    <title>Test Coverage Archive for $name</title>
270</head>
271<body>
272
273<body>
274<h1>$title</h1>
275
276$content
277
278<p>Generated by <a href="http://metacpan.org/module/$class">$class</a> version $version.</p>
279
280</body>
281</html>
282EOTMPL
283
284}
285
286__PACKAGE__->meta->make_immutable;
2871;
288