File Coverage

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

linestmtbrancondsubtimecode
1package App::ArchiveDevelCover;
2
2
2
2
2
2
2
214777
8
41
10
4
112
use 5.010;
3
2
2
2
615
715734
22
use Moose;
4
2
2
2
11548
576519
24
use MooseX::Types::Path::Class;
5
2
2
2
2450
224791
52
use DateTime;
6
2
2
2
420
2849
120
use File::Copy;
7
2
2
2
915
19291
19
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
2
26
    my $self = shift;
19
2
15
    if (-e $self->from->file('coverage.html')) {
20
2
854
        return $self->from->file('coverage.html');
21    }
22    else {
23
0
0
        say "Cannot find 'coverage.html' in ".$self->from.'. Aborting';
24
0
0
        exit;
25    }
26}
27has 'runtime' => (is=>'ro',isa=>'DateTime',lazy_build=>1,traits=> ['NoGetopt'],);
28sub _build_runtime {
29
2
44
    my $self = shift;
30
2
17
    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
1
13
    my $self = shift;
35
1
6
    unless (-e $self->to->file('index.html')) {
36
1
323
        my $tpl = $self->_archive_template;
37
1
8
        my $fh = $self->to->file('index.html')->openw;
38
1
433
        print $fh $tpl;
39
1
13
        close $fh;
40    }
41
1
10
    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
1
12
    my $self = shift;
46
1
22
    return $self->to->file('archive_db');
47}
48has 'previous_stats' => (is=>'ro',isa=>'ArrayRef',lazy_build=>1,traits=>['NoGetopt']);
49sub _build_previous_stats {
50
1
13
    my $self = shift;
51
1
10
    if (-e $self->archive_db) {
52
0
0
        my $dbr = $self->archive_db->openr;
53
0
0
        my @data = <$dbr>; # probably better to just get last line...
54
0
0
        my @prev = split(/;/,$data[-1]);
55
0
0
        return \@prev;
56    }
57    else {
58
1
381
        return [undef,0,0,0];
59    }
60}
61
62sub run {
63
2
242873
    my $self = shift;
64
2
18
    $self->archive;
65
1
5
    $self->update_index;
66}
67
68sub archive {
69
2
5
    my $self = shift;
70
71
2
19
    my $from = $self->from;
72
2
27
    my $target = $self->to->subdir($self->runtime->iso8601);
73
74
2
2412
    if (-e $target) {
75
1
47
        say "This coverage report has already been archived.";
76
1
10
        exit;
77    }
78
79
1
39
    $target->mkpath;
80
1
144
    my $target_string = $target->stringify;
81
82
1
31
    while (my $f = $from->next) {
83
11
5766
        next unless $f=~/\.(html|css)$/;
84
6
290
        copy($f->stringify,$target_string) || die "Cannot copy $from to $target_string: $!";
85    }
86
87
1
286
    say "archived coverage reports at $target_string";
88}
89
90sub update_index {
91
1
3
    my $self = shift;
92
93
1
15
    my $te = HTML::TableExtract->new( headers => [qw(stm sub total)] );
94
1
234
    $te->parse(scalar $self->coverage_html->slurp);
95
1
3154
    my $rows =$te->rows;
96
1
142
    my $last_row = $rows->[-1];
97
98
1
4
    $self->update_archive_html($last_row);
99
1
1224
    $self->update_archive_db($last_row);
100}
101
102sub update_archive_html {
103
1
2
    my ($self, $last_row) = @_;
104
105
1
9
    my $prev_stats = $self->previous_stats;
106
1
24
    my $runtime = $self->runtime;
107
1
14
    my $date = $runtime->ymd('-').' '.$runtime->hms;
108
1
25
    my $link = $runtime->iso8601."/coverage.html";
109
110
1
18
    my $new_stat = qq{\n<tr><td><a href="$link">$date</a></td>};
111
1
3
    foreach my $val (@$last_row) {
112
3
6
        my $style;
113
3
7
        given ($val) {
114
3
3
9
7
            when ($_ < 75) { $style = 'c0' }
115
0
0
0
0
            when ($_ < 90) { $style = 'c1' }
116
0
0
0
0
            when ($_ < 100) { $style = 'c2' }
117
0
0
0
0
            when ($_ >= 100) { $style = 'c3' }
118        }
119
3
12
        $new_stat.=qq{<td class="$style">$val</td>};
120    }
121
1
3
    my $prev_total = $prev_stats->[3];
122
1
3
    my $this_total = $last_row->[-1];
123
1
6
    if ($this_total == $prev_total) {
124
0
0
        $new_stat.=qq{<td class="c3">=</td>};
125    }
126    elsif ($this_total > $prev_total) {
127
1
3
        $new_stat.=qq{<td class="c3">+</td>};
128    }
129    else {
130
0
0
        $new_stat.=qq{<td class="c0">-</td>};
131    }
132
133
1
5
    $new_stat.="</tr>\n";
134
135
1
9
    my $archive = $self->archive_html->slurp;
136
1
1
456
6
    $archive =~ s/(<!-- INSERT -->)/$1 . $new_stat/e;
137
138
1
8
    my $fh = $self->archive_html->openw;
139
1
205
    print $fh $archive;
140
1
10
    close $fh;
141
142
1
8
    unless (-e $self->to->file('cover.css')) {
143
1
369
         copy($self->from->file('cover.css'),$self->to->file('cover.css')) || warn "Cannot copy cover.css: $!";
144    }
145}
146
147sub update_archive_db {
148
1
3
    my ($self, $last_row) = @_;
149
1
8
    my $dbw = $self->archive_db->open(">>") || warn "Can't write archive.db: $!";
150
1
166
    say $dbw join(';',$self->runtime->iso8601,@$last_row);
151
1
86
    close $dbw;
152}
153
154sub _archive_template {
155
1
2
    my $self = shift;
156
1
8
    my $name = $self->project || 'unnamed project';
157
1
11
    my $class = ref($self);
158
1
18
    my $version = $class->VERSION;
159
1
10
    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