# Things to add to existing module
package Devel::Cover::DB::Criterion;
use Devel::Cover::Truth_Table;
use strict;
use warnings;
#-------------------------------------------------------------------------------
# Subroutine : error()
# Purpose : Determine if any of the entries for a given metric type
# of a line of code are missing full coverage.
# Notes :
#-------------------------------------------------------------------------------
sub error {
my $self = shift;
my $line = shift;
foreach my $c (@{$self->get($line)}) {
return 1 if $c->error;
}
return;
}
#-------------------------------------------------------------------------------
# Subroutine : branch_coverage()
# Purpose : Generate textual representation of branches with/without
# coverage.
# Notes :
#-------------------------------------------------------------------------------
sub branch_coverage {
my $self = shift;
my $line = shift;
my @txt;
foreach my $c (@{$self->get($line)}) {
push @txt, ($c->[0][0] ? ' T ' : '---') .
($c->[0][1] ? ' F ' : '---');
}
return @txt;
}
#-------------------------------------------------------------------------------
# Subroutine : truth_table()
# Purpose : Generate truth table(s) for conditional expressions on a line.
# Notes :
#-------------------------------------------------------------------------------
sub truth_table {
my $self = shift;
my $line = shift;
my $c = $self->get($line);
return if @$c > 16; # Too big - can't get any useful info anyway.
my @lops;
foreach my $c (@$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),
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;
}
package Devel::Cover::Truth_Table::Row;
use warnings;
use strict;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my @args = @_;
# use Devel::Cover::Dumper; print Dumper \@args;
return bless {
inputs => $args[0],
result => $args[1],
covered => $args[2],
criterion => $args[2],
}, $class;
}
sub inputs {
my $self = shift;
return @{$self->{inputs}};
}
sub leftcol {
my $self = shift;
return $self->{inputs}[0];
}
sub rightcol {
my $self = shift;
return $self->{inputs}[-1];
}
sub leftelems {
my $self = shift;
my $n = $#{$self->{inputs}};
return @{$self->{inputs}}[0 .. $n - 1];
}
sub rightelems {
my $self = shift;
my $n = $#{$self->{inputs}};
return @{$self->{inputs}}[1 .. $n];
}
sub string {
return "@{$_[0]{inputs}}";
}
sub result {
return $_[0]{result};
}
sub covered {
return $_[0]{covered};
}
sub error {
return 1;
return $_[0]{error}[$_[1]];
}
package Devel::Cover::Truth_Table;
use warnings;
use strict;
our $VERSION = '1.08'; # VERSION
#-------------------------------------------------------------------------------
# Subroutine : new()
# Purpose : Create a new Truth_Table object.
# Notes : Probably best to keep usage of this internal...
#-------------------------------------------------------------------------------
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
return bless [@_], $class;
}
#-------------------------------------------------------------------------------
# Subroutine : new_primitive()
# Purpose : Create a new Truth_Table object based on one of the built-in
# primitives.
# Notes :
#-------------------------------------------------------------------------------
sub new_primitive {
my ($proto, $type, @coverage) = @_;
my %table = (
and_2 => \&boolean_tt,
and_3 => \&and_tt,
or_2 => \&boolean_tt,
or_3 => \&or_tt,
xor_4 => \&xor_tt,
);
return $proto->new($table{$type}->(@coverage));
}
#-------------------------------------------------------------------------------
# Subroutine : error()
# Purpose : Determine if a table is missing full coverage.
# Notes :
#-------------------------------------------------------------------------------
sub error {
my $self = shift;
if (@_) { print "[[[", $self->[shift]->error, "]]]\n"; die }
return $self->[shift]->error if @_;
foreach (@$self) {
return 1 if $_->error;
}
return;
}
#-------------------------------------------------------------------------------
# Subroutine : percentage()
# Purpose : Determine the coverage proportion for a truth table.
# Notes : Don't care states (X) count as one path, not two.
#-------------------------------------------------------------------------------
sub percentage {
my $self = shift;
my ($p, $c) = (scalar @$self, 0);
foreach (@$self) {
$c++ if $_->covered;
}
return ($c == $p) ? 100 : 100 * $c / $p;
}
# Basic truth table constructors
# Construct a new truth table for 'A <op> B' coverage listing
# primitives. More complicated tables are constructed by merging
# primitives. Each array element represents a row from a truth table,
# divided into two parts;
# * the input states: 0/1/X (X = don't care)
# * the output state and a flag to show whether that path has been
# hit.
# e.g. for the source '$a && $b', and_tt(1,0,1) generates this table:
#
# $a | $b | $a && $b | covered
# ----|----|----------|--------
# 0 | X | 0 | 1
# 1 | 0 | 0 | 0
# 1 | 1 | 1 | 1
#
sub and_tt {
return(Devel::Cover::Truth_Table::Row->new([0, 'X'], 0, shift),
Devel::Cover::Truth_Table::Row->new([1, 0 ], 0, shift),
Devel::Cover::Truth_Table::Row->new([1, 1 ], 1, shift));
}
sub or_tt {
return(Devel::Cover::Truth_Table::Row->new([0, 0 ], 0, shift),
Devel::Cover::Truth_Table::Row->new([0, 1 ], 1, shift),
Devel::Cover::Truth_Table::Row->new([1, 'X'], 1, shift));
}
sub xor_tt {
return(Devel::Cover::Truth_Table::Row->new([0, 0], 0, shift),
Devel::Cover::Truth_Table::Row->new([0, 1], 1, shift),
Devel::Cover::Truth_Table::Row->new([1, 0], 1, shift),
Devel::Cover::Truth_Table::Row->new([1, 1], 0, shift));
}
sub boolean_tt {
return(Devel::Cover::Truth_Table::Row->new([0], 0, shift),
Devel::Cover::Truth_Table::Row->new([1], 1, shift));
}
#-------------------------------------------------------------------------------
# Subroutine : sort()
# Purpose : Sort a truth table
# Notes :
#-------------------------------------------------------------------------------
sub sort {
my $self = shift;
@$self = sort {$a->string cmp $b->string} @$self;
return $self;
}
#sub rows {return @{$_[0]}}
#-------------------------------------------------------------------------------
# Subroutine : text()
# Purpose : Formatted text representation of a truth table
# Notes :
#-------------------------------------------------------------------------------
sub text {
my $self = shift;
my $h = 'A';
my @h = map {$h++} ($self->[0]->inputs);
my $hdr = "@h |exp|hit";
my @text;
push @text, $hdr, '-' x length($hdr);
foreach (@$self) {
push @text, sprintf("%s | %s |%s", $_->string(),
$_->result(), $_->covered() ? '+++' : '---');
}
push @text, '-' x length($hdr);
return @text;
}
#-------------------------------------------------------------------------------
# Subroutine : html()
# Purpose : HTML representation of a truth table
# Notes :
#-------------------------------------------------------------------------------
sub html {
my $self = shift;
my @class = (shift || 'uncovered', shift || 'covered');
my $html = "<table><tr>";
my $h = 'A';
for ($self->[0]->inputs) {
$html .= "<th>$h</th>";
$h++;
}
$html .= "<th>dec</th></tr>";
my $c = 0;
foreach (@$self) {
my $class = $class[!$_->error($c++) || $_->covered];
$html .= qq'<tr align="center"><td class="$class">';
$html .= join(qq'</td><td class="$class">', $_->inputs, $_->result);
$html .= "</td></tr>";
}
$html .= "</table>";
return $html;
}
# Truth table merge routines:
# Combine simple truth tables into more complicated ones.
#
# Given two truth tables, A and B, such that
# A is the truth table for the expression 'a1 <op> a2'
# B is the truth table for the expression 'b1 <op> b2'
# b1 = 'a1 <op> a2'
#
# We want to merge the contents of A into B creating a new, larger truth
# table for the composite expression '(a1 <op> a2) <op> b2'. We do this
# by replacing elements of B corresponding to b1 with (all) the inputs
# to A where the result of A matches the element removed from B. e.g.
#
# A => a1 || a2 B => b1 && b2
# a1 a2 | a1 || a2 b1 b2 | b1 && b2
# ---------------- ----------------
# 0 0 | 0 0 X | 0
# 0 1 | 1 1 0 | 0
# 1 X | 1 1 1 | 1
#
# For the first row of B, b1 = 0. We replace this with the all the
# (a1,a2) values where the expression 'a1 || a2' = 0. In this case, just
# (0,0). Thus, the first row of our new table becomes (0,0,X).
#
# In the second row of B, b1 = 1. Thus, from A we add rows for A values
# (0,1) and (1,X) along with the value for b2 (0). Repeat the process
# for the final row of B where b2 = 1. The resulting truth table is:
#
# a1 a2 b2 | (a1 || a2) && b2
# ---------------------------
# 0 0 X | 0
# 0 1 0 | 0
# 1 X 0 | 0
# 0 1 1 | 1
# 1 X 1 | 1
#
# Note that we don't have to calculate the result, it's taken directly
# from table B. We can do this because we've replaced b1 with an
# something that evaluates to the same thing.
#
# This is a "left merge" because we merged A into the leftmost column of
# B. We can also do a "right merge" where we place A into the rightmost
# column of B. (This is what we would have done if we had had
# b2 = 'a1 <op> a2' instead of b1.)
#
# Finally, merging the truth tables isn't much use if we don't work out
# which paths have been covered. We haven't shown it, but each row of
# the truth tables also contains a "covered" boolean. The value of this
# in the merged table is the AND'd values from the input tables A and B.
# In the case where all the inputs from B are 'X' it is simply the
# value from table A.
#-------------------------------------------------------------------------------
# Subroutine : right_merge(\@,\@)
# Purpose : Merge truth table 2 into the rightmost column of truth table 1.
# Notes :
#-------------------------------------------------------------------------------
sub right_merge {
my ($tt1, $tt2) = @_;
# find the rows of tt2 that have a result of false/true
my @merge = ([grep {! $_->result} @$tt2], [grep {$_->result} @$tt2]);
# if the rightmost column of tt1 is 'X', we don't care what the
# input from tt2 was
my @dontcare = map {'X'} $tt2->[0]->inputs;
my @tt;
foreach my $row1 (@$tt1) {
if ($row1->rightcol eq 'X') {
push(@tt, Devel::Cover::Truth_Table::Row->new([$row1->leftelems, @dontcare],
$row1->result, $row1->covered));
}
else {
# expand value from tt1 with rows from tt2 that result in
# that value
foreach my $row2 (@{$merge[$row1->rightcol]}) {
push(@tt, Devel::Cover::Truth_Table::Row->new([$row1->leftelems, $row2->inputs],
$row1->result, $row1->covered && $row2->covered));
}
}
}
$_[0] = $tt2->new(@tt);
}
#-------------------------------------------------------------------------------
# Subroutine : left_merge(\@,\@)
# Purpose : Merge truth table 2 into the leftmost column of truth table 1.
# Notes :
#-------------------------------------------------------------------------------
sub left_merge {
my ($tt1, $tt2) = @_;
# find the rows of tt2 that have a result of false/true
my @merge = ([grep {! $_->result} @$tt2], [grep {$_->result} @$tt2]);
my @tt;
foreach my $row1 (@$tt1) {
my $rightmatters = grep {$_ ne 'X'} $row1->rightelems;
foreach my $row2 (@{$merge[$row1->leftcol]}) {
# expand value from tt1 with rows from tt2 that result in
# that value
push(@tt, Devel::Cover::Truth_Table::Row->new([$row2->inputs, $row1->rightelems],
$row1->result,
($rightmatters) ? $row1->covered && $row2->covered : $row2->covered));
}
}
$_[0] = $tt2->new(@tt);
}
1;
=pod
=head1 NAME
Devel::Cover::Truth_Table - Truth tables for coverage objects.
=head1 VERSION
version 1.08
=head1 SYNOPSIS
use Devel::Cover::Truth_Table;
# $a || $b
my $or_tt = Devel::Cover::Truth_Table->new_primitive('or_3', 0, 1, 1);
# $c && $d
my $and_tt = Devel::Cover::Truth_Table->new_primitive('and_3', 1, 0, 1);
# merge contents of $and_tt into right column of $or_tt, to create
# $a || ($c && $d)
$or_tt->right_merge($and_tt);
# get a (sorted) textual representation
my @text = $or_tt->sort->text;
print "$_\n" foreach @text;
__END__
A B C |exp|hit
--------------
0 0 X | 0 |---
0 1 0 | 0 |---
0 1 1 | 1 |+++
1 X X | 1 |+++
--------------
=head1 DESCRIPTION
This module provides methods for creating and merging conditional
primitives (C<$a && $b>, C<$c || $d>, etc.) into more complex composite
expressions.
=head1 METHODS
=head2 new_primitive($op, @coverage)
Create a new truth table based on one of the built-in primitives, which
are the subclasses of Devel::Cover::DB::Condition. C<$op> is one of the
following:
=over 4
=item and_3
C<and> or C<&&> with three conditional paths.
=item or_3
C<or> or C<||> with three conditional paths.
=item or_2
C<or> or C<||> with two conditional paths. (i.e., when the right hand
side of the expression is a constant)
=item xor_4
C<xor> with four conditional paths.
=back
C<@coverage> is a list booleans identifying which of the possible paths
have been covered.
=head2 sort()
Sorts a truth table (in place) and returns the sorted object.
=head2 text()
Format a truth table to an array of strings for printing.
=head2 html()
Format a truth table in HTML.
=head2 error()
=head2 percentage()
Determines the proportion of possible conditions that have coverage.
=head2 right_merge($sub_table)
Merge entries from C<$sub_table> into right column of table.
=head2 left_merge($sub_table)
Merge entries from C<$sub_table> into left column of table.
=head1 SEE ALSO
Devel::Cover
=head1 BUGS
None that I'm aware of...
=head1 LICENSE
Copyright 2002 Michael Carman <mjcarman@mchsi.com>
This software is free. It is licensed under the same terms as Perl
itself. The latest version should be available from: http://www.pjcj.net
=cut