package Devel::Cover::Report::Html_minimal; BEGIN {require 5.006} use strict; use warnings; use CGI; use Getopt::Long; use Devel::Cover::DB; use Devel::Cover::Html_Common "launch"; use Devel::Cover::Truth_Table; our $VERSION = '1.15'; # VERSION our $LVERSION = do { eval '$VERSION' || "0.001" }; # for development purposes #------------------------------------------------------------------------------- # Subroutine : get_coverage_for_line # Purpose : Retreive all available data for requested metrics on a line. # Notes : #------------------------------------------------------------------------------- sub get_coverage_for_line { my ($options, $data, $line) = @_; my %coverage; foreach my $c (grep {$data->$_()} keys %{$options->{show}}) { my $m = $data->$c()->location($line); $coverage{$c} = $m if $m; } return \%coverage; } #------------------------------------------------------------------------------- # Subroutine : get_summary_for_file # Purpose : # Notes : #------------------------------------------------------------------------------- sub get_summary_for_file { my $db = shift; my $file = shift; my $show = shift; my %summary; my $data = $db->{summary}{$file}; for my $c (@$show) { if (exists $data->{$c}) { $summary{$c} = { percent => do { my $x = sprintf "%5.2f", $data->{$c}{percentage}; chop $x; $x }, ratio => sprintf("%d / %d", $data->{$c}{covered} || 0, $data->{$c}{total} || 0), error => $data->{$c}{error}, }; } else { $summary{$c} = {percent => 'n/a', ratio => undef, error => undef}; } } return \%summary; } #------------------------------------------------------------------------------- # Subroutine : get_showing_headers # Purpose : # Notes : #------------------------------------------------------------------------------- sub get_showing_headers { my $db = shift; my $options = shift; my @crit = $db->criteria; my @short_crit = $db->criteria_short; my @showing = grep $options->{show}{$_}, @crit; my @headers = map { $short_crit[$_] } grep { $options->{show}{$crit[$_]} } (0 .. $#crit); return(\@showing, \@headers); } #------------------------------------------------------------------------------- # Subroutine : truth_table # Purpose : # Notes : #------------------------------------------------------------------------------- sub truth_table { return if @_ > 16; my @lops; my $n = 0; foreach my $c (@_) { my $op = $c->[1]{type}; my @hit = map {defined() && $_ > 0 ? 1 : 0} @{$c->[0]}; @hit = reverse @hit if $op =~ /^or_[23]$/; my $t = { tt => Devel::Cover::Truth_Table->new_primitive($op, @hit), # tt => Devel::Cover::Truth_Table->new_primitive($op, $c, $n++); cvg => $c->[1], expr => join(' ', @{$c->[1]}{qw/left op right/}), }; push(@lops, $t); } return map {[$_->{tt}->sort, $_->{expr}]} merge_lineops(@lops); } #------------------------------------------------------------------------------- # Subroutine : merge_lineops() # Purpose : Merge multiple conditional expressions into composite # truth table(s). # Notes : #------------------------------------------------------------------------------- sub merge_lineops { my @ops = @_; my $rotations; while ($#ops > 0) { my $rm; for (1 .. $#ops) { if ($ops[0]{expr} eq $ops[$_]{cvg}{left}) { $ops[$_]{tt}->left_merge($ops[0]{tt}); $ops[0] = $ops[$_]; $rm = $_; last; } elsif ($ops[0]{expr} eq $ops[$_]{cvg}{right}) { $ops[$_]{tt}->right_merge($ops[0]{tt}); $ops[0] = $ops[$_]; $rm = $_; last; } elsif ($ops[$_]{expr} eq $ops[0]{cvg}{left}) { $ops[0]{tt}->left_merge($ops[$_]{tt}); $rm = $_; last; } elsif ($ops[$_]{expr} eq $ops[0]{cvg}{right}) { $ops[0]{tt}->right_merge($ops[$_]{tt}); $rm = $_; last; } } if ($rm) { splice(@ops, $rm, 1); $rotations = 0; } else { # First op didn't merge with anything. Rotate @ops in hopes # of finding something that can be merged. unshift(@ops, pop @ops); # Hmm... we've come full circle and *still* haven't found # anything to merge. Did the source code have multiple # statements on the same line? last if ($rotations++ > $#ops); } } return @ops; } #=============================================================================== my %Filenames; my @class = qw'c0 c1 c2 c3'; my $threshold = { c0 => 75, c1 => 90, c2 => 100 }; #------------------------------------------------------------------------------- # Subroutine : bclass() # Purpose : Determine the CSS class for an element based on boolean coverage. # Notes : #------------------------------------------------------------------------------- sub bclass { my @c = map {$_ ? $class[-1] : $class[0] } @_; return wantarray ? @c : $c[0]; } #------------------------------------------------------------------------------- # Subroutine : pclass() # Purpose : Determine the CSS class for an element based on percent covered # Notes : #------------------------------------------------------------------------------- sub pclass { my ($p, $e) = @_; return $class[3] unless $e; $p < $threshold->{c0} && return $class[0]; $p < $threshold->{c1} && return $class[1]; $p < $threshold->{c2} && return $class[2]; $class[3] } #------------------------------------------------------------------------------- # Subroutine : get_coverage_report # Purpose : # Notes : #------------------------------------------------------------------------------- sub get_coverage_report { my $type = shift; my $data = shift; return _branch_report($data) if $type eq 'branch'; return _condition_report($data) if $type eq 'condition'; return _time_report($data) if $type eq 'time'; return _count_report($type, $data); } #------------------------------------------------------------------------------- sub _count_report { my $type = shift; my $data = shift; return map {{ class => bclass(!$_->error || $_->covered), percentage => $_->covered, }} @{$data->{$type}} } #------------------------------------------------------------------------------- sub _branch_report { my $coverage = shift; my $sfmt = qq'
TF
'; return map {{ percentage => sprintf("%.0f", $_->percentage), title => sprintf("%s/%s", $_->[0][0] ? 'T' : '-', $_->[0][1] ? 'F' : '-'), class => pclass($_->percentage, $_->error), string => sprintf($sfmt, bclass($_->[0][0]), bclass($_->[0][1])), }} @{$coverage->{branch}} } #------------------------------------------------------------------------------- sub _condition_report { my $coverage = shift; # use Devel::Cover::Dumper; print STDERR Dumper $coverage; my @tables = truth_table(@{$coverage->{condition}}); return unless @tables; return map {{ percentage => sprintf("%.0f", $_->[0]->percentage), class => pclass($_->[0]->percentage, $_->[0]->error), string => $_->[0]->html(bclass(0,1)), }} @tables; } #------------------------------------------------------------------------------- sub _time_report { my $coverage = shift; return map {{string => $_->covered}} @{$coverage->{time}}; } #------------------------------------------------------------------------------- #------------------------------------------------------------------------------- # Subroutine : print_stylesheet() # Purpose : Create the stylesheet for HTML reports. # Notes : #------------------------------------------------------------------------------- sub print_stylesheet { my ($db, $options) = @_; my $file = "$options->{outputdir}/cover.css"; open(my $css, '>', $file) or return; my $p = tell(DATA); print $css ; seek(DATA, $p, 0); close($css); } #------------------------------------------------------------------------------- # Subroutine : print_html_header # Purpose : # Notes : #------------------------------------------------------------------------------- sub print_html_header { my $fh = shift; my $title = shift; print $fh <<"END_HTML"; $title END_HTML } #------------------------------------------------------------------------------- # Subroutine : print_summary # Purpose : # Notes : #------------------------------------------------------------------------------- sub print_summary { my $fh = shift; my $title = shift; my $file = shift; my $percent = sprintf("%.1f", shift @_ || 0); my $error = shift; my $db = shift; my $class = pclass($percent, $error); my $meta = $db->{meta}{$file}; print $fh <<"END_HTML";

$title

File:$file
Coverage:$percent\%

END_HTML } #------------------------------------------------------------------------------- # Subroutine : print_th # Purpose : # Notes : #------------------------------------------------------------------------------- sub print_th { my ($fh, $th, $span) = @_; print $fh ''; foreach my $h (@$th) { print $fh $span->{$h} ? qq'' : ""; } print $fh "\n"; } #------------------------------------------------------------------------------- # Subroutine : get_link # Purpose : # Notes : #------------------------------------------------------------------------------- sub get_link { my $file = shift; my $type = shift; my $line = shift; return unless exists $Filenames{$file}; my $link = $Filenames{$file}; $link .= "--$type" if $type; $link .= ".html"; $link .= "#L$line" if $line; return $link; } #------------------------------------------------------------------------------- # Subroutine : print_summary_report() # Purpose : Print the database summary report. # Notes : #------------------------------------------------------------------------------- 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 = $] < 5.010 ? $] : $^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";

$options->{option}{summarytitle}

$h$h
Database:$db->{db}
Report Date:$date
Perl Version:$perl_v
OS:$os
Thresholds: $c[0]$c[1]$c[2]$c[3]

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''; } else { print $fh qq''; } 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"', $summary->{$c}{ratio}); if ($c =~ /branch|condition|subroutine/) { $link = get_link($file, $c); } } if ($link) { printf $fh qq'%s', $class, $popup, $link, $pc; } else { printf $fh qq'%s', $class, $popup, $pc; } } print $fh "\n"; } print $fh "
$file
$file
\n\n\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 = CGI::escapeHTML($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']); my $autoloader = 0; while (my $sloc = <$in>) { $autoloader ||= $sloc =~ /use\s+AutoLoader/; # Process stuff after __END__ or __DATA__ tokens if (!$autoloader && $sloc =~ /^__(END|DATA)__/) { if ($opt->{option}{data}) { # print all data in one cell my ($i, $n) = ($., scalar @$th); while (my $line = <$in>) { $sloc .= $line } $sloc = escape_HTML($sloc); print $out qq'$i - $.
$sloc
\n'; #   is IE empty cell hack #print $out qq'$i - $. 
$sloc
\n'; } last; } # Process embedded POD if ($sloc =~ /^=(pod|head|over|item|begin|for)/) { if ($opt->{option}{pod}) { # print all POD in one cell my ($i, $n) = ($., scalar @$th); while (my $line = <$in>) { $sloc .= $line; last if $line =~ /^=cut/; } $sloc = escape_HTML($sloc); print $out qq'$i - $.
$sloc
\n'; #   is IE empty cell hack #print $out qq'$i - $. 
$sloc
\n'; } else { 1 while (<$in> !~ /^=cut/); } next; } if ($sloc =~ /^\s*$/) { if ($opt->{option}{pod}) { my $n = @$th + 1; print $out qq'$.'; #   is IE empty cell hack #print $out qq'$. '; } next; } $sloc = escape_HTML($sloc); print $out qq'$.'; my $metric = get_coverage_for_line($opt, $file_data, $.); foreach my $c (@$show) { my @m = get_coverage_report($c, $metric); print $out ''; foreach my $m (@m) { if ($opt->{option}{unified} && ($c eq 'branch' || $c eq 'condition')) { print $out '
', $m->{string}, '
'; } else { my $link; if ($c =~ /branch|condition|subroutine/) { $link = get_link($fin, $c, $.); } no warnings "uninitialized"; # TODO - hack, get rid of this my $text = '{class} ? qq' class="$m->{class}"' : ''; $text .= $m->{title} ? qq' title="$m->{title}"' : ''; $text .= '>'; $text .= $link ? qq'' : ''; $text .= $m->{class} ? $m->{percentage} : $m->{string}; $text .= $link ? '' : ''; print $out $text; } } print $out ''; #print $out ' ' unless @m; # IE empty cell hack } print $out qq'$sloc\n'; } print $out "\n\n\n"; close($in) or warn "Can't close file '$fin' [$!]"; close($out) or warn "Can't close file '$fout' [$!]"; } #------------------------------------------------------------------------------- # Subroutine : print_branch_report() # Purpose : Print branch coverage report for a file. # Notes : #------------------------------------------------------------------------------- sub print_branch_report { my ($db, $file, $opt) = @_; my $data = $db->cover->file($file)->branch; return unless $data; my $fout = "$opt->{outputdir}/$Filenames{$file}--branch.html"; open(my $out, '>', $fout) or warn("Can't open file '$fout' [$!]\n"), return; print_html_header($out, "Branch Coverage: $file"); print_summary($out, 'Branch Coverage', $file, $db->{summary}{$file}{branch}{percentage}, $db->{summary}{$file}{branch}{error}, $db); print_th($out, ['line', '%', 'coverage', 'branch'], {coverage => 2}); my $fmt = qq'%s' . qq'%.0f' . qq'T' . qq'F' . qq'%s\n'; foreach my $line (sort { $a <=> $b } $data->items) { my $n = 0; foreach my $x (@{$data->location($line)}) { my @tf = $x->values; printf $out ($fmt, $n++ > 0 ? '' : qq'$line', pclass($x->percentage, $x->error), $x->percentage, bclass($tf[0]), bclass($tf[1]), escape_HTML($x->text), ); } } print $out "\n\n\n"; close($out) or warn "Can't close file '$fout' [$!]"; } #------------------------------------------------------------------------------- # Subroutine : print_condition_report() # Purpose : Print condition coverage report for a file. # Notes : #------------------------------------------------------------------------------- sub print_condition_report { my ($db, $file, $opt) = @_; my $data = $db->cover->file($file)->condition; return unless $data; my $fout = "$opt->{outputdir}/$Filenames{$file}--condition.html"; open(my $out, '>', $fout) or warn("Can't open file '$fout' [$!]\n"), return; print_html_header($out, "Condition Coverage: $file"); print_summary($out, 'Condition Coverage', $file, $db->{summary}{$file}{condition}{percentage}, $db->{summary}{$file}{condition}{error}, $db); print_th($out, ['line', '%', 'coverage', 'condition']); my $fmt = qq'%s' . qq'%.0f' . qq'%s' . qq'%s\n'; foreach my $line (sort { $a <=> $b } $data->items) { my @tt = $data->truth_table($line); my $n = 0; foreach my $x (@tt) { printf $out ($fmt, $n++ > 0 ? '' : qq'$line', pclass($x->[0]->percentage, $x->[0]->error), $x->[0]->percentage, '
' . $x->[0]->html(bclass(0,1)) . '
', escape_HTML($x->[1]), ); } } print $out "\n\n\n"; close($out) or warn "Can't close file '$fout' [$!]"; } #------------------------------------------------------------------------------- # Subroutine : print_sub_report # Purpose : # Notes : #------------------------------------------------------------------------------- sub print_sub_report { my ($db, $file, $opt) = @_; my $data = $db->cover->file($file)->subroutine; return unless $data; my $fout = "$opt->{outputdir}/$Filenames{$file}--subroutine.html"; open(my $out, '>', $fout) or warn("Can't open file '$fout' [$!]\n"), return; print_html_header($out, "Subroutine Coverage: $file"); print_summary($out, 'Subroutine Coverage', $file, $db->{summary}{$file}{subroutine}{percentage}, $db->{summary}{$file}{subroutine}{error}, $db); print_th($out, ['line', 'subroutine']); my $fmt = qq'%s' . qq'
%s
\n'; foreach my $line (sort { $a <=> $b } $data->items) { my $l = $data->location($line); my $n = 0; foreach my $x (@$l) { printf $out ($fmt, $n++ > 0 ? '' : qq'$line', pclass($x->percentage, $x->error), escape_HTML($x->name), ); } } print $out "\n\n\n"; close($out) or warn "Can't close file '$fout' [$!]"; } sub get_options { my ($self, $opt) = @_; $opt->{option}{pod} = 1; $opt->{option}{outputfile} = "coverage.html"; $opt->{option}{summarytitle} = "Coverage Summary"; $threshold->{$_} = $opt->{"report_$_"} for grep { defined $opt->{"report_$_"} } qw( c0 c1 c2 ); die "Invalid command line options" unless GetOptions($opt->{option}, qw( data! outputfile=s pod! summarytitle=s unified! report_c0=s report_c1=s report_c2=s )); } #------------------------------------------------------------------------------- # Subroutine : report() # Purpose : Entry point for printing HTML reports. # Notes : #------------------------------------------------------------------------------- sub report { my (undef, $db, $opt) = @_; my @files = @{$opt->{file}}; %Filenames = map {$_ => do {(my $f = $_) =~ s/\W/-/g; $f}} @files; print_stylesheet($db, $opt); print_summary_report($db, $opt); for my $file (@files) { print_file_report($db, $file, $opt); unless ($opt->{option}{unified}) { print_branch_report ($db, $file, $opt) if $opt->{show}{branch}; print_condition_report ($db, $file, $opt) if $opt->{show}{condition}; print_sub_report ($db, $file, $opt) if $opt->{show}{subroutine}; } } print "done.\n" unless $opt->{silent}; } =pod =head1 NAME Devel::Cover::Report::Html_minimal - HTML backend for Devel::Cover =head1 VERSION version 1.15 =head1 SYNOPSIS cover -report html_minimal =head1 DESCRIPTION This module provides a HTML reporting mechanism for coverage data. It is designed to be called from the C program. Based on an original by Paul Johnson, the output was greatly improved by Michael Carman (mjcarman@mchsi.com). =head1 OPTIONS Options are specified by adding the appropriate flags to the C program. This report format supports the following: =over 4 =item outputfile Specifies the filename of the main output file. The default is F. Specify F if you just want to publish the whole directory. =item pod Includes POD (and blank lines) in the file report. This is on by default. It may be turned off with -nopod. =item data Includes text after the C<__DATA__> or C<__END__> tokens in the file report. By default, this text is trimmed. Note: If your POD is after an C<__END__>, you have to specify 'data' to include it, not 'pod'. The 'pod' option only applies to POD before the C<__END__>. =item unified Generates a "unified" report for each file. The detailed data that normally appears in the auxiliary reports (branch, condition, etc.) are placed in the file report, and the auxiliary reports are not generated. =item summarytitle Specify the title of the summary. The default is "Coverage Summary". =back =head1 SEE ALSO Devel::Cover =head1 LICENCE Copyright 2001-2014, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. The latest version of this software should be available from my homepage: http://www.pjcj.net =cut 1; __DATA__ /* Stylesheet for Devel::Cover HTML reports */ /* You may modify this file to alter the appearance of your coverage * reports. If you do, you should probably flag it read-only to prevent * future runs from overwriting it. */ /* Note: default values use the color-safe web palette. */ body { font-family: sans-serif; } h1 { background-color: #3399ff; border: solid 1px #999999; padding: 0.2em; -moz-border-radius: 10px; } a { color: #000000; } a:visited { color: #333333; } table { border-collapse: collapse; border-spacing: 0px; } tr { text-align : center; vertical-align: top; } th,.h { background-color: #cccccc; border: solid 1px #333333; padding: 0em 0.2em; } td { border: solid 1px #cccccc; } /* source code */ pre,.s { text-align: left; font-family: monospace; white-space: pre; padding: 0em 0.5em 0em 0.5em; } /* Classes for color-coding coverage information: * c0 : path not covered or coverage < 75% * c1 : coverage >= 75% * c2 : coverage >= 90% * c3 : path covered or coverage = 100% */ .c0, .c1, .c2, .c3 { text-align: right; } .c0 { background-color: #ff9999; border: solid 1px #cc0000; } .c1 { background-color: #ffcc99; border: solid 1px #ff9933; } .c2 { background-color: #ffff99; border: solid 1px #cccc66; } .c3 { background-color: #99ff99; border: solid 1px #009900; }