File: | lib/App/ArchiveDevelCover.pm |
Coverage: | 85.7% |
line | stmt | bran | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | package 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 | |||||
10 | our $VERSION = '1.001'; | |||||
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', lazy_build=>1); | |||||
16 | sub _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 | } | |||||
21 | has 'coverage_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']); | |||||
22 | sub _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 | } | |||||
32 | has 'runtime' => (is=>'ro',isa=>'DateTime',lazy_build=>1,traits=> ['NoGetopt'],); | |||||
33 | sub _build_runtime { | |||||
34 | 4 | 82 | my $self = shift; | |||
35 | 4 | 34 | return DateTime->from_epoch(epoch=>$self->coverage_html->stat->mtime); | |||
36 | } | |||||
37 | has 'archive_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']); | |||||
38 | sub _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 | } | |||||
48 | has 'archive_db' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']); | |||||
49 | sub _build_archive_db { | |||||
50 | 2 | 24 | my $self = shift; | |||
51 | 2 | 14 | return $self->to->file('archive_db'); | |||
52 | } | |||||
53 | has 'previous_stats' => (is=>'ro',isa=>'ArrayRef',lazy_build=>1,traits=>['NoGetopt']); | |||||
54 | sub _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 | } | |||||
66 | has 'diff_html' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']); | |||||
67 | sub _build_diff_html { | |||||
68 | 1 | 13 | my $self = shift; | |||
69 | 1 | 7 | return $self->to->subdir($self->runtime->iso8601)->file('diff.html'); | |||
70 | } | |||||
71 | ||||||
72 | sub 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 | ||||||
79 | sub 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 | ||||||
101 | sub 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 | ||||||
113 | sub 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 | ||||||
152 | sub 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 | ||||||
159 | sub 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 -> $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 | ||||||
214 | sub 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 | ||||||
227 | sub _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 | ||||||
240 | sub _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> | |||||
248 | DATA | |||||
249 | </table> | |||||
250 | }); | |||||
251 | } | |||||
252 | ||||||
253 | sub _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> | |||||
282 | EOTMPL | |||||
283 | ||||||
284 | } | |||||
285 | ||||||
286 | __PACKAGE__->meta->make_immutable; | |||||
287 | 1; | |||||
288 |