use t::lib;
use strict;
use Test::More;
use Class::AutoDB::Registration;
use Class::AutoDB::Collection;
# Test Class::AutoDB::Collection
# Simple black box testing of the interface
sub test {
my($testname,$name,$regs,$keys)=@_;
my @args;
push(@args,(-name=>$name)) if $name;
my $collection=new Class::AutoDB::Collection(@args);
isa_ok($collection,'Class::AutoDB::Collection',"$testname: collection");
$regs=[$regs] if $regs && 'ARRAY' ne ref $regs;
for my $reg (@$regs) {
$collection->register($reg->keys);
}
test_really($testname,$collection,$name,$keys);
}
sub test_really {
my($testname,$collection,$name,$keys)=@_;
is($collection->name,$name,"$testname: name");
my %t_keys=$collection->keys;
my $t_keys=$collection->keys;
is_deeply(\%t_keys,$keys||{},"$testname: keys as HASH");
is_deeply($t_keys,$keys||{},"$testname: keys as HASH ref");
my @t_tables=$collection->tables;
my $t_tables=$collection->tables;
ok_tables($name,\@t_tables,$keys,"$testname: tables as ARRAY");
ok_tables($name,$t_tables,$keys,"$testname: tables as ARRAY ref");
# test schema methods -- Table tests do the heavy lifting, just test counts here
if ($name) {
my $count=scalar @t_tables;
my @t_create=$collection->create;
my $t_create=$collection->create;
is(scalar @t_create,2*$count,"$testname: create as ARRAY");
is(scalar @$t_create,2*$count,"$testname: create as ARRAY ref");
my @t_drop=$collection->drop;
my $t_drop=$collection->drop;
is(scalar @t_drop,$count,"$testname: drop as ARRAY");
is(scalar @$t_drop,$count,"$testname: drop as ARRAY ref");
}
$collection;
}
sub norm_tables {
my $name=shift;
return undef unless $_[0];
my @norm;
if ('HASH' eq ref $_[0]) { # infer tables from $keys
my($keys)=@_;
# base table for scalar keys
my $base_table=new Class::AutoDB::Table(-name=>$name);
my $base_keys={};
push(@norm,$base_table);
while(my($key,$type)=each %$keys) {
if (my($list_type)=$type=~/list\s*\((.*)\s*\)/i) {
# link table for list key
my $list_table=new Class::AutoDB::Table(-name=>$name."_$key",-keys=>{$key=>$list_type});
push(@norm,$list_table);
} else {
$base_keys->{$key}=$type;
}
}
$base_table->keys($base_keys);
} elsif ('ARRAY' eq ref $_[0]) { # ARRAY of tables from Collection object
@norm=@{$_[0]};
} else {
die "Unkown argument type for norm_table"
}
@norm=sort {$a->name cmp $b->name} @norm;
\@norm;
}
sub ok_tables {
my($name,$t_tables,$keys,$label)=@_;
is_deeply(norm_tables($name,$t_tables),norm_tables($name,$keys||{}),$label);
}
# Tests start here
#goto skip;
my $collection=test('empty collection');
my $collection=test
('collection with name',
'Person',
undef,
undef,
);
my $collection=test
('collection with registration - scalar keys only',
undef,
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(name string, dob integer, significant_other object)),
{name=>'string',dob=>'integer',significant_other=>'object'},
);
my $collection=test
('collection with registration - scalar keys and 1 list key',
undef,
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(name string, dob integer, significant_other object, friends list(object))),
{name=>'string',dob=>'integer',significant_other=>'object',friends=>'list(object)'},
);
my $collection=test
('collection with name and registration - scalar keys only',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(name string, dob integer, significant_other object)),
{name=>'string',dob=>'integer',significant_other=>'object'},
);
my $collection=test
('collection with name and registration - scalar keys and 1 list key',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(name string, dob integer, significant_other object, friends list(object))),
{name=>'string',dob=>'integer',significant_other=>'object',friends=>'list(object)'},
);
my $collection=test
('collection with name and registration - 1 key of each type (scalar and list)',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 integer, skey3 float, skey4 object,
lkey1 list(string), lkey2 list(integer), lkey3 list(float), lkey4 list(object))),
{skey1=>'string',skey2=>'integer',skey3=>'float',skey4=>'object',
lkey1=>'list(string)',lkey2=>'list(integer)',lkey3=>'list(float)',lkey4=>'list(object)'},
);
my $collection=test
('collection with name and 2 registrations - identical',
'Person',
[new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 integer, skey3 float, skey4 object,
lkey1 list(string), lkey2 list(integer), lkey3 list(float), lkey4 list(object))),
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 integer, skey3 float, skey4 object,
lkey1 list(string), lkey2 list(integer), lkey3 list(float), lkey4 list(object))),
],
{skey1=>'string',skey2=>'integer',skey3=>'float',skey4=>'object',
lkey1=>'list(string)',lkey2=>'list(integer)',lkey3=>'list(float)',lkey4=>'list(object)'},
);
my $collection=test
('collection with name and 2 registrations - disjoint',
'Person',
[new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 integer,
lkey1 list(string), lkey2 list(integer))),
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey3 float, skey4 object,
lkey3 list(float), lkey4 list(object))),
],
{skey1=>'string',skey2=>'integer',skey3=>'float',skey4=>'object',
lkey1=>'list(string)',lkey2=>'list(integer)',lkey3=>'list(float)',lkey4=>'list(object)'},
);
my $collection=test
('collection with name and 2 registrations - overlapping consistent',
'Person',
[new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 integer, skey3 float,
lkey1 list(string), lkey2 list(integer), lkey3 list(float))),
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey2 integer, skey3 float, skey4 object,
lkey2 list(integer), lkey3 list(float), lkey4 list(object))),
],
{skey1=>'string',skey2=>'integer',skey3=>'float',skey4=>'object',
lkey1=>'list(string)',lkey2=>'list(integer)',lkey3=>'list(float)',lkey4=>'list(object)'},
);
my $collection=new Class::AutoDB::Collection(-name=>'Person');
my $reg1=new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 integer, skey3 string,
lkey1 list(string), lkey2 list(integer), lkey3 list(string)));
my $reg2=new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey2 string, skey3 float, skey4 object,
lkey2 list(string), lkey3 list(float), lkey4 list(object)));
$collection->register($reg1->keys);
eval {
$collection->register($reg2->keys);
};
ok($@=~ /Inconsistent registrations/i,'collection with name and 2 inconsistent registrations');
# Test boundary cases for keys
my $collection=test
('collection with name and 0 keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration'),
{},
);
my $collection=test
('collection with name and 1 scalar key',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string)),
{skey1=>'string'},
);
my $collection=test
('collection with name and 2 scalar keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 string)),
{skey1=>'string',skey2=>'string'},
);
my $collection=test
('collection with name and 3 scalar keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 string, skey3 string)),
{skey1=>'string',skey2=>'string',skey3=>'string'},
);
my $collection=test
('collection with name and 4 scalar keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 string, skey3 string, skey4 string)),
{skey1=>'string',skey2=>'string',skey3=>'string',skey4=>'string'},
);
my $collection=test
('collection with name and 1 list key',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(lkey1 list(string))),
{lkey1=>'list(string)'},
);
my $collection=test
('collection with name and 2 list keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(lkey1 list(string), lkey2 list(string))),
{lkey1=>'list(string)',lkey2=>'list(string)'},
);
my $collection=test
('collection with name and 3 list keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(lkey1 list(string), lkey2 list(string), lkey3 list(string))),
{lkey1=>'list(string)',lkey2=>'list(string)',lkey3=>'list(string)'},
);
my $collection=test
('collection with name and 4 list keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(lkey1 list(string), lkey2 list(string), lkey3 list(string), lkey4 list(string))),
{lkey1=>'list(string)',lkey2=>'list(string)',lkey3=>'list(string)',lkey4=>'list(string)'},
);
my $collection=test
('collection with name and 1 scalar and 1 list key',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string,
lkey1 list(string))),
{skey1=>'string',
lkey1=>'list(string)'},
);
my $collection=test
('collection with name and 2 scalar and 2 list keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 string,
lkey1 list(string), lkey2 list(string))),
{skey1=>'string',skey2=>'string',
lkey1=>'list(string)',lkey2=>'list(string)'},
);
my $collection=test
('collection with name and 3 scalar and 3 list keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 string, skey3 string,
lkey1 list(string), lkey2 list(string), lkey3 list(string))),
{skey1=>'string',skey2=>'string',skey3=>'string',
lkey1=>'list(string)',lkey2=>'list(string)',lkey3=>'list(string)'},
);
my $collection=test
('collection with name and 4 scalar and 4 list keys',
'Person',
new Class::AutoDB::Registration
(-class=>'Registration',
-keys=>q(skey1 string, skey2 string, skey3 string, skey4 string,
lkey1 list(string), lkey2 list(string), lkey3 list(string), lkey4 list(string))),
{skey1=>'string',skey2=>'string',skey3=>'string',skey4=>'string',
lkey1=>'list(string)',lkey2=>'list(string)',lkey3=>'list(string)',lkey4=>'list(string)'},
);
# Test boundary cases for registrations
my $collection=test
('collection with name and 0 registrations',
'Person',
[],
{},
);
my $collection=test
('collection with name and 1 registration',
'Person',
[new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey1 string)),
],
{skey1=>'string'},
);
my $collection=test
('collection with name and 2 registrations',
'Person',
[new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey1 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey2 string)),
],
{skey1=>'string',skey2=>'string'},
);
my $collection=test
('collection with name and 3 registrations',
'Person',
[new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey1 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey2 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey3 string)),
],
{skey1=>'string',skey2=>'string',skey3=>'string'},
);
my $collection=test
('collection with name and 4 registrations',
'Person',
[new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey1 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey2 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey3 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey4 string)),
],
{skey1=>'string',skey2=>'string',skey3=>'string',skey4=>'string'},
);
# Test mutators and register
# Start with empty object
my $collection=new Class::AutoDB::Collection;
$collection->name('Person');
test_really
('collection after name set',
$collection,'Person',
{},
);
my $collection=test
('collection after register - 0 registrations','Person',[],{});
my $collection=test
('collection after register - 1 registration','Person',
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey1 string)),
{skey1=>'string'},
);
my $collection=test
('collection after register - 2 registrations','Person',
[new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey1 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey2 string))],
{skey1=>'string',skey2=>'string'},
);
my $collection=test
('collection after register - 3 registrations','Person',
[new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey1 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey2 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey3 string))],
{skey1=>'string',skey2=>'string',skey3=>'string'},
);
my $collection=test
('collection after register - 4 registrations','Person',
[new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey1 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey2 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey3 string)),
new Class::AutoDB::Registration(-class=>'Registration',-keys=>q(skey4 string))],
{skey1=>'string',skey2=>'string',skey3=>'string',skey4=>'string'},
);
done_testing();