Devel-Cover
view release on metacpan or search on metacpan
lib/Devel/Cover/Report/Html_minimal.pm view on Meta::CPAN
#-------------------------------------------------------------------------------
sub print_summary_report {
my ($db, $options) = @_;
my $outfile = "$options->{outputdir}/$options->{option}{outputfile}";
open(my $fh, '>', $outfile)
or warn("Unable to open file '$outfile' [$!]\n"), return;
my ($show, $th) = get_showing_headers($db, $options);
push @$show, 'total';
my $le = sub { ($_[0] > 0 ? "<" : "=") . " $_[0]%" };
my $ge = sub { ($_[0] < 100 ? ">" : "") . "= $_[0]%" };
my @c = (
$le->($options->{report_c0}), $le->($options->{report_c1}),
$le->($options->{report_c2}), $ge->($options->{report_c2}),
);
my $date = do {
my ($sec, $min, $hour, $mday, $mon, $year) = localtime;
sprintf "%04d-%02d-%02d %02d:%02d:%02d", $year + 1900, $mon + 1, $mday,
$hour, $min, $sec
};
my $perl_v = $^V;
my $os = $^O;
print_html_header($fh, $options->{option}{summarytitle});
# TODO - >= 100% doesn't look nice. See also Html_basic.
print $fh <<"END_HTML";
<body>
<h1>$options->{option}{summarytitle}</h1>
<table>
<tr><td class="h" align="right">Database:</td><td align="left" colspan="4">$db->{db}</td></tr>
<tr><td class="h" align="right">Report Date:</td><td align="left" colspan="4">$date</td></tr>
<tr><td class="h" align="right">Perl Version:</td><td align="left" colspan="4">$perl_v</td></tr>
<tr><td class="h" align="right">OS:</td><td align="left" colspan="4">$os</td></tr>
<tr>
<td class="h" align="right">Thresholds:</td>
<td class="c0">$c[0]</td><td class="c1">$c[1]</td><td class="c2">$c[2]</td><td class="c3">$c[3]</td>
</tr>
</table>
<div><br/></div>
<table>
END_HTML
print_th($fh, [ 'file', @$th, 'total' ]);
my @files = (grep($db->{summary}{$_}, @{ $options->{file} }), 'Total');
for my $file (@files) {
my $summary = get_summary_for_file($db, $file, $show);
my $url = get_link($file);
if ($url) {
print $fh qq'<tr><td align="left"><a href="$url">$file</a></td>';
} else {
print $fh qq'<tr><td align="left">$file</td>';
}
for my $c (@$show) {
my $pc = $summary->{$c}{percent};
my ($class, $popup, $link);
if ($pc eq 'n/a' || $c eq 'time') {
$class = $popup = '';
} else {
$class = sprintf(qq' class="%s"', pclass($pc, $summary->{$c}{error}));
$popup = sprintf(qq' title="%s"', $c . ': ' . $summary->{$c}{ratio});
if ($c =~ /branch|condition|subroutine/) {
$link = get_link($file, $c);
}
}
if ($link) {
printf $fh qq'<td%s%s><a href="%s">%s</a></td>', $class, $popup, $link,
$pc;
} else {
printf $fh qq'<td%s%s>%s</td>', $class, $popup, $pc;
}
}
print $fh "</tr>\n";
}
print $fh "</table>\n</body>\n</html>\n";
close($fh) or warn "Unable to close '$outfile' [$!]";
print "HTML output written to $outfile\n" unless $options->{silent};
}
#-------------------------------------------------------------------------------
# Subroutine : escape_HTML
# Purpose : make source code web-safe
# Notes :
#-------------------------------------------------------------------------------
sub escape_HTML {
my $text = shift;
chomp $text;
$text = encode_entities($text);
# Do not allow FF in text
$text =~ tr/\x0c//d;
# IE doesn't honor "white-space: pre" CSS
my @text = split m/\n/ => $text;
for (@text) {
# Expand all tabs to spaces
1 while s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
# make multiple spaces be multiple spaces
s/( +)/' ' x length $1/ge;
}
return join "\n" => @text;
}
#-------------------------------------------------------------------------------
# Subroutine : print_file_report()
# Purpose : Print coverage overview report for a file.
# Notes :
#-------------------------------------------------------------------------------
sub print_file_report {
my ($db, $fin, $opt) = @_;
my $fout = "$opt->{outputdir}/$Filenames{$fin}.html";
open(my $in, '<', $fin) or warn("Can't read file '$fin' [$!]\n"), return;
open(my $out, '>', $fout) or warn("Can't open file '$fout' [$!]\n"), return;
my ($show, $th) = get_showing_headers($db, $opt);
my $file_data = $db->cover->file($fin);
print_html_header($out, "File Coverage: $fin");
print_summary(
$out, 'File Coverage',
$fin,
$db->{summary}{$fin}{total}{percentage},
$db->{summary}{$fin}{total}{error}, $db
);
print_th($out, [ 'line', @$th, 'code' ]);
( run in 2.887 seconds using v1.01-cache-2.11-cpan-364913b4093 )