File: | lib/App/ArchiveDevelCover.pm |
Coverage: | 82.1% |
line | stmt | bran | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | package App::ArchiveDevelCover; | |||||
2 | 4 4 4 4 4 4 | 382362 16 82 18 9 225 | use 5.010; | |||
3 | 4 4 4 | 1214 1380334 46 | use Moose; | |||
4 | 4 4 4 | 23021 1101040 45 | use MooseX::Types::Path::Class; | |||
5 | 4 4 4 | 4877 429711 107 | use DateTime; | |||
6 | 4 4 4 | 691 4616 232 | use File::Copy; | |||
7 | 4 4 4 | 1779 38019 42 | use HTML::TableExtract; | |||
8 | ||||||
9 | # ABSTRACT: Archive Devel::Cover reports | |||||
10 | our $VERSION = '1.000'; | |||||
11 | ||||||
12 | with 'MooseX::Getopt'; | |||||
13 | ||||||
14 | has [qw(from to)] => (is=>'ro',isa=>'Path::Class::Dir',coerce=>1,required=>1,); | |||||
15 | has 'project' => (is => 'ro', isa=>'Str'); | |||||
16 | has 'coverage_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']); | |||||
17 | sub _build_coverage_html { | |||||
18 | 5 | 62 | my $self = shift; | |||
19 | 5 | 36 | if (-e $self->from->file('coverage.html')) { | |||
20 | 5 | 1822 | 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 | } | |||||
27 | has 'runtime' => (is=>'ro',isa=>'DateTime',lazy_build=>1,traits=> ['NoGetopt'],); | |||||
28 | sub _build_runtime { | |||||
29 | 5 | 102 | my $self = shift; | |||
30 | 5 | 43 | return DateTime->from_epoch(epoch=>$self->coverage_html->stat->mtime); | |||
31 | } | |||||
32 | has 'archive_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']); | |||||
33 | sub _build_archive_html { | |||||
34 | 3 | 39 | my $self = shift; | |||
35 | 3 | 20 | unless (-e $self->to->file('index.html')) { | |||
36 | 2 | 632 | my $tpl = $self->_archive_template; | |||
37 | 2 | 17 | my $fh = $self->to->file('index.html')->openw; | |||
38 | 2 | 862 | print $fh $tpl; | |||
39 | 2 | 25 | close $fh; | |||
40 | } | |||||
41 | 3 | 355 | return $self->to->file('index.html'); | |||
42 | } | |||||
43 | has 'archive_db' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']); | |||||
44 | sub _build_archive_db { | |||||
45 | 3 | 36 | my $self = shift; | |||
46 | 3 | 39 | return $self->to->file('archive_db'); | |||
47 | } | |||||
48 | has 'previous_stats' => (is=>'ro',isa=>'ArrayRef',lazy_build=>1,traits=>['NoGetopt']); | |||||
49 | sub _build_previous_stats { | |||||
50 | 3 | 40 | my $self = shift; | |||
51 | 3 | 32 | if (-e $self->archive_db) { | |||
52 | 1 | 343 | my $dbr = $self->archive_db->openr; | |||
53 | 1 | 172 | my @data = <$dbr>; # probably better to just get last line... | |||
54 | 1 | 5 | my @prev = split(/;/,$data[-1]); | |||
55 | 1 | 12 | return \@prev; | |||
56 | } | |||||
57 | else { | |||||
58 | 2 | 752 | return [undef,0,0,0]; | |||
59 | } | |||||
60 | } | |||||
61 | ||||||
62 | sub run { | |||||
63 | 5 | 477261 | my $self = shift; | |||
64 | 5 | 31 | $self->archive; | |||
65 | 3 | 13 | $self->update_index; | |||
66 | } | |||||
67 | ||||||
68 | sub archive { | |||||
69 | 5 | 14 | my $self = shift; | |||
70 | ||||||
71 | 5 | 46 | my $from = $self->from; | |||
72 | 5 | 70 | my $target = $self->to->subdir($self->runtime->iso8601); | |||
73 | ||||||
74 | 5 | 5582 | if (-e $target) { | |||
75 | 2 | 91 | say "This coverage report has already been archived."; | |||
76 | 2 | 19 | exit; | |||
77 | } | |||||
78 | ||||||
79 | 3 | 110 | $target->mkpath; | |||
80 | 3 | 372 | my $target_string = $target->stringify; | |||
81 | ||||||
82 | 3 | 91 | while (my $f = $from->next) { | |||
83 | 33 | 16697 | next unless $f=~/\.(html|css)$/; | |||
84 | 18 | 871 | copy($f->stringify,$target_string) || die "Cannot copy $from to $target_string: $!"; | |||
85 | } | |||||
86 | ||||||
87 | 3 | 825 | say "archived coverage reports at $target_string"; | |||
88 | } | |||||
89 | ||||||
90 | sub update_index { | |||||
91 | 3 | 9 | my $self = shift; | |||
92 | ||||||
93 | 3 | 42 | my $te = HTML::TableExtract->new( headers => [qw(stm sub total)] ); | |||
94 | 3 | 525 | $te->parse(scalar $self->coverage_html->slurp); | |||
95 | 3 | 9331 | my $rows =$te->rows; | |||
96 | 3 | 430 | my $last_row = $rows->[-1]; | |||
97 | ||||||
98 | 3 | 11 | $self->update_archive_html($last_row); | |||
99 | 3 | 2626 | $self->update_archive_db($last_row); | |||
100 | } | |||||
101 | ||||||
102 | sub update_archive_html { | |||||
103 | 3 | 8 | my ($self, $last_row) = @_; | |||
104 | ||||||
105 | 3 | 28 | my $prev_stats = $self->previous_stats; | |||
106 | 3 | 58 | my $runtime = $self->runtime; | |||
107 | 3 | 48 | my $date = $runtime->ymd('-').' '.$runtime->hms; | |||
108 | 3 | 72 | my $link = $runtime->iso8601."/coverage.html"; | |||
109 | ||||||
110 | 3 | 52 | my $new_stat = qq{\n<tr><td><a href="$link">$date</a></td>}; | |||
111 | 3 | 11 | foreach my $val (@$last_row) { | |||
112 | 9 | 17 | my $style; | |||
113 | 9 | 19 | given ($val) { | |||
114 | 9 6 | 25 13 | when ($_ < 75) { $style = 'c0' } | |||
115 | 3 2 | 8 5 | when ($_ < 90) { $style = 'c1' } | |||
116 | 1 0 | 2 0 | when ($_ < 100) { $style = 'c2' } | |||
117 | 1 1 | 3 3 | when ($_ >= 100) { $style = 'c3' } | |||
118 | } | |||||
119 | 9 | 29 | $new_stat.=qq{<td class="$style">$val</td>}; | |||
120 | } | |||||
121 | 3 | 8 | my $prev_total = $prev_stats->[3]; | |||
122 | 3 | 8 | my $this_total = $last_row->[-1]; | |||
123 | 3 | 16 | if ($this_total == $prev_total) { | |||
124 | 0 | 0 | $new_stat.=qq{<td class="c3">=</td>}; | |||
125 | } | |||||
126 | elsif ($this_total > $prev_total) { | |||||
127 | 3 | 8 | $new_stat.=qq{<td class="c3">+</td>}; | |||
128 | } | |||||
129 | else { | |||||
130 | 0 | 0 | $new_stat.=qq{<td class="c0">-</td>}; | |||
131 | } | |||||
132 | ||||||
133 | 3 | 10 | $new_stat.="</tr>\n"; | |||
134 | ||||||
135 | 3 | 28 | my $archive = $self->archive_html->slurp; | |||
136 | 3 3 | 1357 16 | $archive =~ s/(<!-- INSERT -->)/$1 . $new_stat/e; | |||
137 | ||||||
138 | 3 | 23 | my $fh = $self->archive_html->openw; | |||
139 | 3 | 538 | print $fh $archive; | |||
140 | 3 | 27 | close $fh; | |||
141 | ||||||
142 | 3 | 25 | unless (-e $self->to->file('cover.css')) { | |||
143 | 2 | 689 | copy($self->from->file('cover.css'),$self->to->file('cover.css')) || warn "Cannot copy cover.css: $!"; | |||
144 | } | |||||
145 | } | |||||
146 | ||||||
147 | sub update_archive_db { | |||||
148 | 3 | 8 | my ($self, $last_row) = @_; | |||
149 | 3 | 22 | my $dbw = $self->archive_db->open(">>") || warn "Can't write archive.db: $!"; | |||
150 | 3 | 479 | say $dbw join(';',$self->runtime->iso8601,@$last_row); | |||
151 | 3 | 230 | close $dbw; | |||
152 | } | |||||
153 | ||||||
154 | sub _archive_template { | |||||
155 | 2 | 4 | my $self = shift; | |||
156 | 2 | 17 | my $name = $self->project || 'unnamed project'; | |||
157 | 2 | 22 | my $class = ref($self); | |||
158 | 2 | 41 | my $version = $class->VERSION; | |||
159 | 2 | 20 | 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> | |||||
185 | EOTMPL | |||||
186 | } | |||||
187 | ||||||
188 | __PACKAGE__->meta->make_immutable; | |||||
189 | 1; | |||||
190 |