# 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..85\n"; }
END {print "not ok 1\n" unless $loaded;}
use Genezzo::Block::Std;
use Genezzo::Block::RowDir;
use Genezzo::Block::RDBlkA;
$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;
our $splicetype = 1;
if (0)
{
# XXX XXX: need to test bad negative offsets and negative lengths...
splicecheck (-12, -50);
splicecheck (-12, -50, qw(aa bb cc dd ee ff gg hh ii));
splicecheck (-12, -50, qw(aa bb cc dd));
}
if (1)
{
splicecheck ();
splicecheck (-1);
splicecheck (10);
splicecheck (10,5);
splicecheck (10, 5, qw(aa bb cc dd));
splicecheck (10, 20, qw(aa bb cc dd));
splicecheck (3, 2, qw(aa bb cc));
splicecheck (10, 5, qw(aa bb cc dd ee ff gg hh ii));
splicecheck (12,5);
splicecheck (12, 5, qw(aa bb cc dd ee ff gg hh ii));
splicecheck (12, 5, qw(aa bb cc dd ee ));
splicecheck (12, 5, qw(aa bb ));
splicecheck (12, -5);
splicecheck (12, -5, qw(aa bb cc dd ee ff gg hh ii));
splicecheck (12, -5, qw(aa bb cc dd ));
splicecheck (-12, -5);
splicecheck (-12, -5, qw(aa bb cc dd ee ff gg hh ii));
splicecheck (-12, -5, qw(aa bb cc dd));
splicecheck (-12, 5);
splicecheck (-12, 5, qw(aa bb cc dd ee ff gg hh ii));
splicecheck (-12, 5, qw(aa bb cc dd ));
}
{
splicecheck (10, 0, qw(aa));
splicecheck (0, 10, qw(aa));
splicecheck (0, 0, qw(aa));
splicecheck (1, 0, qw(aa));
splicecheck (1, 1, qw(aa));
splicecheck (0, 1, qw(aa));
}
if (1)
{
ordcheck(3, 2, 1);
ordcheck(10, 7, 5, 6, 3, 2, 1);
ordcheck(1, 2, 3, 4, 5);
}
if (0)
{
# XXX: need a way to check error string
local $splicetype = 0;
splicecheck(50, 5);
}
sub ordcheck
{
use Genezzo::Util;
my @args = @_;
# whoami @_;
local $Genezzo::Block::Std::DEFBLOCKSIZE = 5000;
my $buff = "\0" x 5000;
my %h1;
my $tie_thing = tie %h1, "Genezzo::Block::RDBlkA", (refbufstr => \$buff);
my @a1;
my $v1 = shift @args;
push (@a1, $v1);
$tie_thing->HPush($v1);
foreach my $val (@args)
{
my ($i, $i2);
{
my $arrsize = scalar(@a1);
$i = 0;
for (; $i < $arrsize; $i++)
{
# break if can insert key before
last
if ($val < $a1[$i]);
}
if ($i < $arrsize)
{
splice (@a1, $i, 0, $val);
}
else
{
push @a1, $val;
}
}
{
$i2 = 0;
my ($kk, $vv);
my $a = scalar keys %h1;
while (($kk, $vv) = each(%h1))
{
# print "$kk : $vv\n";
last
if ($val < $vv);
$i2++;
}
if (defined($kk))
{
$tie_thing->HSplice($i2, 0, $val);
}
else
{
$tie_thing->PUSH($val);
}
}
} # end foreach
# greet %h1;
# greet @a1;
my $loopfail = 0;
if (scalar(keys(%h1)) == scalar(@a1))
{
my $i = 0;
while ( my ($kk, $vv) = each(%h1))
{
unless ($vv eq $a1[$i])
{
$loopfail = 1;
last;
}
$i++;
}
}
else
{
# print scalar(keys(%h1)), " != ", scalar(@a1), "\n";
$loopfail = 1;
}
if ($loopfail)
{
not_ok( "mismatch between pushed and fetched values" );
}
else { ok(); }
}
sub splicecheck
{
use Genezzo::Util;
my @args = @_;
whoami @_;
local $Genezzo::Block::Std::DEFBLOCKSIZE = 5000;
my $buff = "\0" x 5000;
my %h1;
my $tie_thing = tie %h1, "Genezzo::Block::RDBlkA", (refbufstr => \$buff);
my @a1;
for my $val (1..10)
{
my $vv = "a_" . $val . "_1";
$tie_thing->PUSH($vv);
push @a1, $vv;
}
for my $val (1..10)
{
my $vv = "b_" . $val . "_1";
$tie_thing->PUSH($vv);
push @a1, $vv;
}
# test if push was successful for both pushhash and array
my $loopfail = 0;
if (scalar(keys(%h1)) == scalar(@a1))
{
my $i = 0;
while ( my ($kk, $vv) = each(%h1))
{
unless ($vv eq $a1[$i])
{
$loopfail = 1;
last;
}
$i++;
}
}
else
{
# print scalar(keys(%h1)), " != ", scalar(@a1), "\n";
$loopfail = 1;
}
if ($loopfail)
{
not_ok( "mismatch between pushed and fetched values" );
}
else { ok(); }
my @b1;
if (1)
{
my $off = (@_) ? shift : 0;
my $hadlen = (@_);
my $len = $hadlen ? shift : scalar(@a1);
@b1 = splice @a1, $off, $len, @_;
}
else
{
# this doesn't work correctly
@b1 = splice @a1, @_;
}
my @outi;
if (1 == $splicetype)
{
@outi = $tie_thing->HSplice(@args);
}
else
{
my $errstr;
@outi = $tie_thing->HeSplice(\$errstr, @args);
print "error is: $errstr\n";
}
whoami "outi",@outi;
whoami "h1",values(%h1);
whoami "b1",@b1;
whoami "a1",@a1;
$loopfail = 0;
if (scalar(@outi) == scalar(@b1))
{
for (my $i = 0; $i < scalar(@outi); $i++)
{
# print "$i : ",$outi[$i]," -- ", $b1[$i], "\n";
unless ($outi[$i] eq $b1[$i])
{
$loopfail = 1;
# last;
}
}
}
else
{
# print scalar(@outi), " != ", scalar(@b1), "\n";
$loopfail = 1;
}
if ($loopfail)
{
not_ok( "mismatch between pushed and fetched values ("
. $args[0] . " " . $args[1] . ")"
);
}
else { ok(); }
# print "hash : ";
$loopfail = 0;
if (scalar(keys(%h1)) == scalar(@a1))
{
my $i = 0;
while ( my ($kk, $vv) = each(%h1))
{
# print "$kk : $vv -- ", $a1[$i], "\n";
unless ($vv eq $a1[$i])
{
$loopfail = 1;
# last;
}
$i++;
}
}
else
{
# print scalar(keys(%h1)), " != ", scalar(@a1), "\n";
$loopfail = 1;
}
if ($loopfail)
{
not_ok( "mismatch between pushed and fetched values" );
}
else { ok(); }
}
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++;
}