File Coverage

blib/lib/Test/Stream/Delta.pm

Criterion	Covered	Total	%
statement	159	160	99.3
branch	77	80	96.2
condition	47	53	88.6
subroutine	26	26	100.0
pod	12	13	92.3
total	321	332	96.6

package Test::Stream::Delta;
use strict;
use warnings;

use Test::Stream::HashBase(
    accessors => [qw/verified id got chk children dne exception/]
);

use Test::Stream::Table();
use Test::Stream::Context();

use Test::Stream::Util qw/render_ref/;
use Scalar::Util qw/reftype blessed refaddr/;

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 }},
);

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 ref($value) && reftype($value) eq 'CODE';

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

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

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 = $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 'ARRAY';
    return "$id()" if $type eq 'METHOD';
    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 $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;
    my $check = $self->check || return 0;
    return 0 unless $check->lines;
    my $file = $check->file || return 0;

    my $ctx = Test::Stream::Context::context();
    my $cfile = $ctx->debug->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;

    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;

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

    return '' unless @$lines;

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

sub table_got_lines {
    my $self = shift;

    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 @out;

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

    my $max = exists $ENV{TS_MAX_DELTA} ? $ENV{TS_MAX_DELTA} : 25;
    if ($max && @$rows > $max) {
        @$rows = @{$rows}[0 .. ($max - 1)];
        push @out => (
            "************************************************************",
            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 @no_collapse = grep { $COLUMNS{$COLUMN_ORDER[$_]}->{no_collapse} } 0 .. $#COLUMN_ORDER;
    unshift @out => Test::Stream::Table::table(
        header      => $header,
        rows        => $rows,
        collapse    => 1,
        sanitize    => 1,
        mark_tail   => 1,
        no_collapse => \@no_collapse,
    );

    return @out;
}

1;

__END__