package Devel::Cover::Report::Text2; use strict; use warnings; our $VERSION = '1.15'; # VERSION use Devel::Cover::DB; use Devel::Cover::Truth_Table; my %format = ( line => "%4s ", err => "%3s ", statement => "%4s ", condition => "%-24s ", branch => "%-6s ", time => "%6s ", code => "| %s\n", ); #------------------------------------------------------------------------------- # Subroutine : headers() # Purpose : Determine field headers for report. # Notes : #------------------------------------------------------------------------------- sub headers { my ($db, $options) = @_; my ($fmt, @data); for (qw/line err/) { $fmt .= $format{$_}; push @data, $_; } my %cr; @cr{$db->criteria} = $db->criteria_short; foreach my $c ($db->criteria) { next unless $options->{show}{$c}; $fmt .= $format{$c}; push @data, $cr{$c}; } $fmt .= $format{code}; push @data, 'code'; return $fmt, @data; } #------------------------------------------------------------------------------- # Subroutine : get_metrics() # Purpose : Determine which metrics to include in report. # Notes : #------------------------------------------------------------------------------- sub get_metrics { my ($db, $options, $file_data, $line) = @_; my %m; for my $c ($db->criteria) { # find all metrics available in db next unless $options->{show}{$c}; # skip those we don't want in report my $criterion = $file_data->$c(); # check if metric collected for this file if ($criterion) { # if it exists... my $li = $criterion->location($line); # get the metric info for the current line $m{$c} = $li ? [@$li] : undef; # and stash it } } return %m; } #------------------------------------------------------------------------------- # Subroutine : print_file() # Purpose : Print report for file. # Notes : #------------------------------------------------------------------------------- sub print_file { my ($db, $file, $options) = @_; open(F, '<', $file) or warn("Unable to open '$file' [$!]\n"), return; my $pct = sprintf("%.1f%%", $db->{summary}{$file}{total}{percentage}); my $pver = join('.', map {ord} split(//, $^V)); print <cover->file($file); while (my $line = ) { chomp $line; my $error; my %metric = get_metrics($db, $options, $file_data, $.); my @out = ([$.], ['']); foreach my $c ($db->criteria) { next unless $options->{show}{$c}; push(@out, []), next unless $metric{$c}; my $value = []; if ($c eq 'branch') { @$value = $file_data->branch->branch_coverage($.); $error ||= $file_data->branch->error($.); } elsif ($c eq 'condition') { @$value = map {$_->[0]->text} $file_data->condition->truth_table($.); $error ||= $file_data->condition->error($.); } else { while (my $o = shift @{$metric{$c}}) { push @$value, ($c =~ /statement|pod|time/) ? $o->covered : $o->percentage; $error ||= $o->error; } } push @out, $value; } $out[1] = ['***'] if $error; # flag missing coverage push @out, [$line]; foreach my $i (0 .. max(map {$#$_} @out)) { no warnings 'uninitialized'; printf $fmt, map{$_->[$i]} @out; } last if $line =~ /^__(END|DATA)__/; } close F or die "Unable to close '$file' [$!]"; print "\n\n"; } #------------------------------------------------------------------------------- # Subroutine : max() # Purpose : Return the maximum from a list of numbers. # Notes : #------------------------------------------------------------------------------- sub max { my $max = shift; foreach (@_) { $max = $_ if $_ > $max; } return $max; } #------------------------------------------------------------------------------- # Subroutine : report() # Purpose : Entry point for creating textual reports. # Notes : #------------------------------------------------------------------------------- sub report { my ($pkg, $db, $options) = @_; foreach my $file (@{$options->{file}}) { print_file($db, $file, $options); } } 1; __END__ =head1 NAME Devel::Cover::Report::Test2 - Text backend for Devel::Cover =head1 VERSION version 1.15 =head1 SYNOPSIS cover -report text2 =head1 DESCRIPTION This module provides a textual reporting mechanism for coverage data. It is designed to be called from the C program. =head1 SEE ALSO Devel::Cover =head1 BUGS Huh? =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