| File: | lib/App/ArchiveDevelCover.pm |
| Coverage: | 18.5% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package 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 | |||||
| 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 | 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 | } | |||||
| 27 | has 'runtime' => (is=>'ro',isa=>'DateTime',lazy_build=>1,traits=> ['NoGetopt'],); | |||||
| 28 | sub _build_runtime { | |||||
| 29 | 0 | my $self = shift; | ||||
| 30 | 0 | 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 | 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 | } | |||||
| 43 | has 'archive_db' => (is=>'ro',isa=>'Path::Class::File',lazy_build=>1,traits=> ['NoGetopt']); | |||||
| 44 | sub _build_archive_db { | |||||
| 45 | 0 | my $self = shift; | ||||
| 46 | 0 | 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 | 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 | ||||||
| 62 | sub run { | |||||
| 63 | 0 | my $self = shift; | ||||
| 64 | 0 | $self->archive; | ||||
| 65 | 0 | $self->update_index; | ||||
| 66 | } | |||||
| 67 | ||||||
| 68 | sub 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 | ||||||
| 90 | sub 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 | ||||||
| 102 | sub 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 | ||||||
| 147 | sub 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 | ||||||
| 154 | sub _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> | |||||
| 185 | EOTMPL | |||||
| 186 | } | |||||
| 187 | ||||||
| 188 | __PACKAGE__->meta->make_immutable; | |||||
| 189 | 1; | |||||
| 190 | ||||||