File Coverage

blib/lib/Test2/Compare/Delta.pm

Criterion	Covered	Total	%
statement	180	181	99.4
branch	101	104	97.1
condition	42	46	91.3
subroutine	28	28	100.0
pod	13	15	86.6
total	364	374	97.3

package Test2::Compare::Delta;
use strict;
use warnings;

our $VERSION = '0.000156';

use Test2::Util::HashBase qw{verified id got chk children dne exception note};

use Test2::EventFacet::Info::Table;

use Test2::Util::Table();
use Test2::API qw/context/;

use Test2::Util::Ref qw/render_ref rtype/;
use Carp qw/croak/;

# 'CHECK' constant would not work, but I like exposing 'check()' to people
# using this class.
BEGIN {
    no warnings 'once';
    *check = \&chk;
    *set_check = \&set_chk;
}

my @COLUMN_ORDER = qw/PATH GLNs GOT OP CHECK CLNs/;
my %COLUMNS = (
    GOT   => {name => 'GOT',   value => sub { $_[0]->render_got },   no_collapse => 1},
    CHECK => {name => 'CHECK', value => sub { $_[0]->render_check }, no_collapse => 1},
    OP    => {name => 'OP',    value => sub { $_[0]->table_op }                      },
    PATH  => {name => 'PATH',  value => sub { $_[1] }                                },

    'GLNs' => {name => 'GLNs', alias => 'LNs', value => sub { $_[0]->table_got_lines }  },
    'CLNs' => {name => 'CLNs', alias => 'LNs', value => sub { $_[0]->table_check_lines }},
);
{
    my $i = 0;
    $COLUMNS{$_}->{id} = $i++ for @COLUMN_ORDER;
}

sub remove_column {
    my $class = shift;
    my $header = shift;
    @COLUMN_ORDER = grep { $_ ne $header } @COLUMN_ORDER;
    delete $COLUMNS{$header} ? 1 : 0;
}

sub add_column {
    my $class = shift;
    my $name = shift;

    croak "Column name is required"
        unless $name;

    croak "Column '$name' is already defined"
        if $COLUMNS{$name};

    my %params;
    if (@_ == 1) {
        %params = (value => @_, name => $name);
    }
    else {
        %params = (@_, name => $name);
    }

    my $value = $params{value};

    croak "You must specify a 'value' callback"
        unless $value;

    croak "'value' callback must be a CODE reference"
        unless rtype($value) eq 'CODE';

    if ($params{prefix}) {
        unshift @COLUMN_ORDER => $name;
    }
    else {
        push @COLUMN_ORDER => $name;
    }

    $COLUMNS{$name} = \%params;
}

sub set_column_alias {
    my ($class, $name, $alias) = @_;

    croak "Tried to alias a non-existent column"
        unless exists $COLUMNS{$name};

    croak "Missing alias" unless defined $alias;

    $COLUMNS{$name}->{alias} = $alias;
}

sub init {
    my $self = shift;

    croak "Cannot specify both 'check' and 'chk' as arguments"
        if exists($self->{check}) && exists($self->{+CHK});

    # Allow 'check' as an argument
    $self->{+CHK} ||= delete $self->{check}
        if exists $self->{check};
}

sub render_got {
    my $self = shift;

    my $exp = $self->{+EXCEPTION};
    if ($exp) {
        chomp($exp = "$exp");
        $exp =~ s/\n.*$//g;
        return "";
    }

    my $dne = $self->{+DNE};
    return '' if $dne && $dne eq 'got';

    my $got = $self->{+GOT};
    return '' unless defined $got;

    my $check = $self->{+CHK};
    my $stringify = defined( $check ) && $check->stringify_got;

    return render_ref($got) if ref $got && !$stringify;

    return "$got";
}

sub render_check {
    my $self = shift;

    my $dne = $self->{+DNE};
    return '' if $dne && $dne eq 'check';

    my $check = $self->{+CHK};
    return '' unless defined $check;

    return $check->render;
}

sub _full_id {
    my ($type, $id) = @_;
    return "<$id>" if !$type || $type eq 'META';
    return $id     if $type eq 'SCALAR';
    return "{$id}" if $type eq 'HASH';
    return "{$id} " if $type eq 'HASHKEY';
    return "[$id]" if $type eq 'ARRAY';
    return "$id()" if $type eq 'METHOD';
    return "$id" if $type eq 'DEREF';
    return "<$id>";
}

sub _arrow_id {
    my ($path, $type) = @_;
    return '' unless $path;

    return ' ' if !$type || $type eq 'META';    # Meta gets a space, not an arrow

    return '->' if $type eq 'METHOD';           # Method always needs an arrow
    return '->' if $type eq 'SCALAR';           # Scalar always needs an arrow
    return '->' if $type eq 'DEREF';            # deref always needs arrow
    return '->' if $path =~ m/(>|\(\))$/;       # Need an arrow after meta, or after a method
    return '->' if $path eq '$VAR';             # Need an arrow after the initial ref

    # Hash and array need an arrow unless they follow another hash/array
    return '->' if $type =~ m/^(HASH|ARRAY)$/ && $path !~ m/(\]|\})$/;

    # No arrow needed
    return '';
}

sub _join_id {
    my ($path, $parts) = @_;
    my ($type, $key) = @$parts;

    my $id   = _full_id($type, $key);
    my $join = _arrow_id($path, $type);

    return "${path}${join}${id}";
}

sub should_show {
    my $self = shift;
    return 1 unless $self->verified;
    defined( my $check = $self->check ) || return 0;
    return 0 unless $check->lines;
    my $file = $check->file || return 0;

    my $ctx = context();
    my $cfile = $ctx->trace->file;
    $ctx->release;
    return 0 unless $file eq $cfile;

    return 1;
}

sub filter_visible {
    my $self = shift;

    my @deltas;
    my @queue = (['', $self]);

    while (my $set = shift @queue) {
        my ($path, $delta) = @$set;

        push @deltas => [$path, $delta] if $delta->should_show;

        my $children = $delta->children || next;
        next unless @$children;

        my @new;
        for my $child (@$children) {
            my $cpath = _join_id($path, $child->id);
            push @new => [$cpath, $child];
        }
        unshift @queue => @new;
    }

    return \@deltas;
}

sub table_header { [map {$COLUMNS{$_}->{alias} || $_} @COLUMN_ORDER] }

sub table_op {
    my $self = shift;

    defined( my $check = $self->{+CHK} ) || return '!exists';

    return $check->operator($self->{+GOT})
        unless $self->{+DNE} && $self->{+DNE} eq 'got';

    return $check->operator();
}

sub table_check_lines {
    my $self = shift;

    defined( my $check = $self->{+CHK} ) || return '';
    my $lines = $check->lines || return '';

    return '' unless @$lines;

    return join ', ' => @$lines;
}

sub table_got_lines {
    my $self = shift;

    defined( my $check = $self->{+CHK} ) || return '';
    return '' if $self->{+DNE} && $self->{+DNE} eq 'got';

    my @lines = $check->got_lines($self->{+GOT});
    return '' unless @lines;

    return join ', ' => @lines;
}

sub table_rows {
    my $self = shift;

    my $deltas = $self->filter_visible;

    my @rows;
    for my $set (@$deltas) {
        my ($id, $d) = @$set;

        my @row;
        for my $col (@COLUMN_ORDER) {
            my $spec = $COLUMNS{$col};
            my $val = $spec->{value}->($d, $id);
            $val = '' unless defined $val;
            push @row => $val;
        }

        push @rows => \@row;
    }

    return \@rows;
}

sub table {
    my $self = shift;

    my @diag;
    my $header = $self->table_header;
    my $rows   = $self->table_rows;

    my $render_rows = [@$rows];
    my $max = exists $ENV{TS_MAX_DELTA} ? $ENV{TS_MAX_DELTA} : 25;
    if ($max && @$render_rows > $max) {
        @$render_rows = map { [@$_] } @{$render_rows}[0 .. ($max - 1)];
        @diag = (
            "************************************************************",
            sprintf("* Stopped after %-42.42s *", "$max differences."),
            "* Set the TS_MAX_DELTA environment var to raise the limit. *",
            "* Set it to 0 for no limit.                                *",
            "************************************************************",
        );
    }

    my @dne;
    for my $row (@$render_rows) {
        my $got = $row->[$COLUMNS{GOT}->{id}]   || '';
        my $chk = $row->[$COLUMNS{CHECK}->{id}] || '';
        if ($got eq '') {
            push @dne => "$row->[$COLUMNS{PATH}->{id}]:   DOES NOT EXIST";
        }
        elsif ($chk eq '') {
            push @dne => "$row->[$COLUMNS{PATH}->{id}]: SHOULD NOT EXIST";
        }
    }

    if (@dne) {
        unshift @dne => '==== Summary of missing/extra items ====';
        push    @dne => '== end summary of missing/extra items ==';
    }

    my $table_args = {
        header      => $header,
        collapse    => 1,
        sanitize    => 1,
        mark_tail   => 1,
        no_collapse => [grep { $COLUMNS{$COLUMN_ORDER[$_]}->{no_collapse} } 0 .. $#COLUMN_ORDER],
    };

    my $render = join "\n" => (
        Test2::Util::Table::table(%$table_args, rows => $render_rows),
        @dne,
        @diag,
    );

    my $table = Test2::EventFacet::Info::Table->new(
        %$table_args,
        rows      => $rows,
        as_string => $render,
    );

    return $table;
}

sub diag { shift->table }

1;

__END__