package testload;
use strict;
use Test::More;
use File::Spec;
use vars qw( @ISA @EXPORT $Dat_Dir
@LINEAGE_DATA @HEADERS @SKEW_DATA
@GNARLY_DATA @TRANSLATION_DATA
);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw( $Dat_Dir @LINEAGE_DATA @HEADERS @SKEW_DATA
i @TRANSLATION_DATA @GNARLY_DATA
good_data good_slice_data good_skew_data
good_gnarly_data good_sticky_data
);
my $base_dir;
BEGIN {
my $pkg = __PACKAGE__;
$pkg =~ s%::%/%g;
$pkg .= '.pm';
my @parts = File::Spec->splitpath(File::Spec->canonpath($INC{$pkg}));
$parts[-1] = '';
$base_dir = File::Spec->catpath(@parts);
}
$Dat_Dir = $base_dir;
# For dataset 'chain'
@LINEAGE_DATA = (
[ '0,0,1,0', '1,0,1,0', '2,0,1,0', '3,0' ],
[ '0,0,1,0', '1,0,1,0', '2,0,2,1', '3,1' ],
[ '0,0,1,0', '1,0,1,0', '2,0' ],
[ '0,0,1,0', '1,0,2,1', '2,1,1,1', '3,2' ],
[ '0,0,1,0', '1,0,2,1', '2,1,2,0', '3,3' ],
[ '0,0,1,0', '1,0,2,1', '2,1' ],
[ '0,0,1,0', '1,0' ],
[ '0,0,2,1', '1,1,1,1', '2,2,1,0', '3,4' ],
[ '0,0,2,1', '1,1,1,1', '2,2,2,1', '3,5' ],
[ '0,0,2,1', '1,1,1,1', '2,2' ],
[ '0,0,2,1', '1,1,2,0', '2,3,1,1', '3,6' ],
[ '0,0,2,1', '1,1,2,0', '2,3,2,0', '3,7' ],
[ '0,0,2,1', '1,1,2,0', '2,3' ],
[ '0,0,2,1', '1,1' ],
[ '0,0' ]
);
# For data set 'basic'
@HEADERS = (
'Header Zero',
'Header One',
'Header Two',
'Header Three',
'Header Four',
'Header Five',
'Header Six',
'Header Seven',
'Header Eight',
'Header Nine',
);
# For data set 'skew'
@SKEW_DATA = (
[ 'head0','head1','head2','head3' ],
[ 'THIS IS A WHOLE ROW-CELL OF JUNK','','','' ],
[ 'JUNK','Tasty tidbit (1,1)','JUNK','Tasty tidbit (1,3)' ],
[ '',"BIG\nJUNK",'','Tasty tidbit (2,3)' ],
[ 'Tasty tidbit (3,0)','','','Tasty tidbit (3,3)' ],
[ 'Tasty tidbit (4,0)','','','Tasty tidbit (4,3)' ],
[ 'JUNK BUTTON','','Tasty tidbit (5,2)','Tasty tidbit (5,3)' ],
);
@TRANSLATION_DATA = (
[ '0,0', '0,1', '0,2', '0,3' ],
[ '1,0', '1,0', '1,0', '1,0' ],
[ '2,0', '2,1', '2,2', '2,3' ],
[ '2,0', '3,1', '3,1', '3,3' ],
[ '4,0', '3,1', '3,1', '4,3' ],
[ '5,0', '3,1', '3,1', '5,3' ],
[ '6,0', '6,0', '6,2', '6,3' ]
);
@GNARLY_DATA = (
[ '(0,0) [1,4]', '', '', '', '(0,1) [2,4]', '', '', '' ],
[ '(1,0) [2,1]', '(1,1) [1,1]', '(1,2) [1,2]', '', '', '', '', '' ],
[ '', '(2,0) [2,4]', '', '', '', '(2,1) [2,2]', '', '(2,2) [1,1]' ],
[ '(3,0) [1,1]', '', '', '', '', '', '', '(3,1) [1,1]' ],
[ '(4,0) [3,2]', '', '(4,1) [1,1]', '(4,2) [3,1]', '(4,3) [4,4]', '', '', '' ],
[ '', '', '(5,0) [1,1]', '', '', '', '', '' ],
[ '', '', '(6,0) [1,1]', '', '', '', '', '' ],
[ '(7,0) [1,4]', '', '', '', '', '', '', '' ]
);
sub good_data {
my($ts, $label, @slice) = @_;
ref $ts or die "Oops: Table state ref required\n";
my $t = $ts->{grid};
my $skew;
my $txt = ref $t->[0][0] eq 'SCALAR' ?
${$t->[0][0]} : $t->[0][0]->as_text;
$skew = $txt =~ /^Header/ ? 1 : 0;
my $row = 0 + $skew;
if (@slice) {
my @rows = $ts->rows;
cmp_ok(scalar @slice, '==', scalar @{$rows[0]}, "$label (col cnt)");
}
# Must have rows
ok(scalar @{$t}, "$label (rows)");
# See if we got the numbers.
foreach my $r ($row .. $#$t) {
# Must have columns
ok(scalar @{$t->[$r]}, "$label (columns)");
my @indices = @slice ? @slice : 0 .. $#{$t->[$r]};
foreach my $c (@indices) {
my $rc = $skew ? $r : $r + 1;
next if $ts->{headers} && !$ts->{hits}{$c};
my $txt = ref $t->[$r][$c] eq 'SCALAR' ?
${$t->[$r][$c]} : $t->[$r][$c]->as_text;
like($txt, qr/^ \($rc,$c\)/, "$label ($r,$c)");
}
}
# Header order check
if ($skew) {
foreach my $c (0 .. $#{$t->[0]}) {
my $hs = $HEADERS[$c];
my $txt = ref $t->[0][$c] eq 'SCALAR' ?
${$t->[0][$c]} : $t->[0][$c]->as_text;
like($txt, qr/^$hs$/, "$label (header order)");
}
}
1;
}
sub good_slice_data {
my($ts, $label, @slice) = @_;
my $t = $ts->{grid};
my @rows = $ts->rows;
my $txt = ref $t->[0][0] eq 'SCALAR' ?
${$t->[0][0]} : $t->[0][0]->as_text;
my $skew = 1;
foreach my $r (0 .. $#rows) {
my $row = $rows[$r];
my $trow = $t->[$r+$skew];
ok(@$row == @slice, "$label (slice width)");
my @s = $ts->column_map;
foreach my $c (0 .. $#$row) {
my $sc = $s[$c];
my $cell = $trow->[$sc];
my $txt = ref $cell eq 'SCALAR' ?
$$cell : $cell->as_text;
ok($row->[$c] eq $txt, "$label ($r,$c)");
}
}
}
sub good_skew_data {
push(@_, 0) if @_ == 2;
_good_span_data(@_, \@SKEW_DATA);
}
sub good_gnarly_data {
push(@_, 0) if @_ == 2;
_good_span_data(@_, \@GNARLY_DATA);
}
sub _good_span_data {
my($ts, $label, $reverse, $REF_DATA) = @_;
ref $ts or die "Oops: Table state ref required\n";
my $t = $ts->{grid};
foreach my $r (1 .. $#$t) {
my $row = $t->[$r];
my @cols = 0 .. $#$row;
@cols = reverse @cols if $reverse;
foreach my $c (@cols) {
my $txt = ref $row->[$c] eq 'SCALAR' ? ${$row->[$c]} : $row->[$c]->as_text;
$txt = '' unless defined $txt;
cmp_ok($txt, 'eq', $REF_DATA->[$r][$c], $label);
}
}
1;
}
sub good_sticky_data {
# testing grid aliasing
my($ts, $label, $reverse) = @_;
ref $ts or die "Oops: Table state ref required\n";
my $t = $ts->_gridalias;
foreach my $r (0 .. $#$t) {
my $row = $t->[$r];
my @cols = 0 .. $#$row;
@cols = reverse @cols if $reverse;
foreach my $c (@cols) {
my $txt = ref $row->[$c] eq 'SCALAR' ?
${$row->[$c]} : $row->[$c]->as_text;
my($tr,$tc) = $ts->source_coords($r,$c);
cmp_ok("$tr,$tc", 'eq', $TRANSLATION_DATA[$r][$c], "$label (coords)");
my $trow = $t->[$tr];
my $ttxt = ref $trow->[$tc] eq 'SCALAR' ?
${$trow->[$tc]} : $trow->[$tc]->as_text;
cmp_ok($ttxt, 'eq', $txt, "$label (content)");
cmp_ok($ttxt, 'eq', $SKEW_DATA[$tr][$tc], "$label (abs)");
}
}
1;
}
1;