# Copyright (c) 2003, 2004 Jeffrey I Cohen. All rights reserved.
#
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
BEGIN { $| = 1; print "1..325\n"; }
END {print "not ok 1\n" unless $loaded;}
use Genezzo::Block::Std;
use Genezzo::Block::RowDir;
use Genezzo::Block::RDBlock;
use Genezzo::Util;
$loaded = 1;
print "ok 1\n";
######################### End of black magic.
# Insert your test code below (better if it prints "ok 13"
# (correspondingly "not ok 13") depending on the success of chunk 13
# of the test code):
use strict;
use warnings;
my $TEST_COUNT;
$TEST_COUNT = 2;
{
# look for XXX XXX: most interesting line
# to observe packing
tt1(150);
tt1(200);
tt1(1000);
tt2(150);
tt2(200);
tt2(1000);
}
sub tt1
{
my $bsize = shift;
local $Genezzo::Block::Std::DEFBLOCKSIZE = $bsize;
my @buffarr;
my $cnt = 50;
my @hasharr;
# build an array of hashes to tie, plus some byte buffers
for my $i (1..$cnt)
{
push @hasharr, {};
push @buffarr, "\0" x (1+$bsize);
}
my @tiearr;
# tie all the hashes
for my $i (0..$cnt-1)
{
my $tie_thing = tie %{$hasharr[$i]},
"Genezzo::Block::RDBlock", (refbufstr => \$buffarr[$i])
or
not_ok( "Couldn't create new RDBlock" );
ok();
push @tiearr, $tie_thing;
}
my @plist = qw(alpha bravo charlie delta echo foxtrot golf hotel
india juliet kilo lima mike november oscar papa quebec
romeo sierra tango uniform victor whiskey xray
yankee zulu);
my ($place, $off, $frag) = $tiearr[0]->HSuck (value =>\@plist);
# should be able to pack partially
if (defined($place))
{
ok();
}
else
{
not_ok( "suck");
}
my $jj = 0;
{
my $next;
if (defined($frag))
{
$next = $frag . ":";
}
else
{
$next = ":"
}
$next .= $jj . '/' . $place;
$jj++;
# pack remainder or fail out...
while (defined($off))
{
($place, $off, $frag) = $tiearr[$jj]->HSuck (
value =>\@plist,
next => $next,
offset => $off
);
unless (defined($place))
{
not_ok( "suck2");
return undef;
}
if (defined($frag))
{
$next = $frag . ":";
}
else
{
$next = ":"
}
$next .= $jj . '/' . $place;
$jj++;
}
}
ok();
$jj--;
# unpack the the most recent piece, which is the head
my @rw1 = $tiearr[$jj]->_fetch2($place);
my @foo = UnPackRow($rw1[0]);
my @pl2; # build an array as unpack
my $gotFrag = 0;
# really a while loop, but fix iteration to prevent infinite loop on error
for my $i (1..$cnt+5)
{
# greet @foo; # XXX XXX: most interesting line to watch
if ($gotFrag)
{ # fragmented - merge the next piece
my $h1 = shift @foo;
$pl2[-1] .= $h1;
}
# we packed tail to head, and we unpack head to tail
push @pl2, @foo;
my $nextp = pop @foo;
# greet $nn;
# cheap test for next ptr
last
unless (defined($nextp) && ($nextp =~ m:/: ));
pop @pl2 ; # last elt was next ptr, so remove it
my ($frag, $nn) = split(':', $nextp);
my ($chunk, $slice) = split('/', $nn);
$gotFrag = (defined($frag)) && ($frag =~ m/F/);
# greet $chunk, $slice;
@rw1 = $tiearr[$chunk]->_fetch2($slice);
@foo = UnPackRow($rw1[0]);
}
# greet @pl2;
if (scalar(@pl2) == scalar(@plist))
{
ok();
}
else
{
not_ok( "count mismatch");
}
for my $i (0..(scalar(@pl2)-1))
{
unless ($pl2[$i] eq $plist[$i])
{
not_ok( "$i : " . $pl2[$i] . " vs " . $plist[$i]);
last;
}
}
ok();
return 1;
} # end tt1
sub tt2
{
my $bsize = shift;
local $Genezzo::Block::Std::DEFBLOCKSIZE = $bsize;
my @buffarr;
my $cnt = 50;
my @hasharr;
# build an array of hashes to tie, plus some byte buffers
for my $i (1..$cnt)
{
push @hasharr, {};
push @buffarr, "\0" x (1+$bsize);
}
my @tiearr;
# tie all the hashes
for my $i (0..$cnt-1)
{
my $tie_thing = tie %{$hasharr[$i]},
"Genezzo::Block::RDBlock", (refbufstr => \$buffarr[$i])
or
not_ok( "Couldn't create new RDBlock" );
ok();
push @tiearr, $tie_thing;
}
my @plist =
qw(
alpha_bravo_charlie_delta_echo_foxtrot_golf_hotel
india_juliet_kilo_lima_mike_november_oscar_papa_quebec
romeo_sierra_tango_uniform_victor_whiskey_xray_yankee_zulu
);
my ($place, $off, $frag) = $tiearr[0]->HSuck (value =>\@plist);
# greet $place, $off, $frag;
# should be able to pack partially
if (defined($place))
{
ok();
}
else
{
not_ok( "suck");
return undef;
}
my $jj = 0;
{
my $next;
if (defined($frag))
{
$next = $frag . ":";
}
else
{
$next = ":"
}
$next .= $jj . '/' . $place;
$jj++;
# pack remainder or fail out...
while (defined($off))
{
($place, $off, $frag) = $tiearr[$jj]->HSuck (
value =>\@plist,
next => $next,
offset => $off
);
unless (defined($place))
{
not_ok( "suck2");
return undef;
}
if (defined($frag))
{
$next = $frag . ":";
}
else
{
$next = ":"
}
$next .= $jj . '/' . $place;
$jj++;
}
}
ok();
$jj--;
# unpack the the most recent piece, which is the head
my @foo = UnPackRow( $tiearr[$jj]->FETCH($place));
my @pl2; # build an array as unpack
if (0)
{
my $ggg = 10; # split('/',$foo[-1]);
while ($ggg)
{
greet UnPackRow( $tiearr[$ggg]->FETCH(0));
$ggg--;
}
}
my $gotFrag = 0;
# really a while loop, but fix iteration to prevent infinite loop on error
for my $i (1..$cnt+5)
{
# greet @foo; # XXX XXX: most interesting line to watch
if ($gotFrag)
{ # fragmented - merge the next piece
my $h1 = shift @foo;
$pl2[-1] .= $h1;
}
# we packed tail to head, and we unpack head to tail
push @pl2, @foo;
my $nextp = pop @foo;
# greet $nextp;
# cheap test for next ptr
last
unless (defined($nextp) && ($nextp =~ m:/: ));
pop @pl2 ; # last elt was next ptr, so remove it
my ($frag, $nn) = split(':', $nextp);
my ($chunk, $slice) = split('/', $nn);
$gotFrag = (defined($frag)) && ($frag =~ m/F/);
# greet $chunk, $slice;
@foo = UnPackRow( $tiearr[$chunk]->FETCH($slice));
}
# greet @pl2;
if (scalar(@pl2) == scalar(@plist))
{
ok();
}
else
{
not_ok( "count mismatch");
}
for my $i (0..(scalar(@pl2)-1))
{
unless ($pl2[$i] eq $plist[$i])
{
not_ok( "$i : " . $pl2[$i] . " vs " . $plist[$i]);
last;
# greet $pl2[$i];
}
}
ok();
return 1;
} # end tt2
sub ok
{
print "ok $TEST_COUNT\n";
$TEST_COUNT++;
}
sub not_ok
{
my ( $message ) = @_;
print "not ok $TEST_COUNT # $message\n";
$TEST_COUNT++;
}
sub skip
{
my ( $message ) = @_;
print "ok $TEST_COUNT # skipped: $message\n";
$TEST_COUNT++;
}