libdevel-cover-perl 1.23-2+b1 / usr / lib / x86_64-linux-gnu / perl5 / 5.24 / Devel / Cover / Report / Text2.pm

package Devel::Cover::Report::Text2;
use strict;
use warnings;

our $VERSION = '1.23'; # 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 <<EOT;
#         File: $file
#     Coverage: $pct
# Perl Version: $pver
#     Platform: $^O

EOT

    my ($fmt, @out) = headers($db, $options);
    printf $fmt, @out;

    my $file_data = $db->cover->file($file);
    while (my $line = <F>) {
        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.23

=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<cover> program.

=head1 SEE ALSO

 Devel::Cover

=head1 BUGS

Huh?

=head1 LICENCE

Copyright 2001-2016, 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