/usr/local/CPAN/XAO-FS/XAO/testcases/FS/fields.pm
package XAO::testcases::FS::fields;
use strict;
use XAO::Utils;
use XAO::Objects;
use Error qw(:try);
use base qw(XAO::testcases::FS::base);
##
# MySQL is noisy about mistakes that we expect. So we hide DBD
# messages.
#
use vars qw(*SE);
sub stderr_stop {
open(SE,">&STDERR");
open(STDERR,">/dev/null");
}
sub stderr_restore {
open(STDERR,">&SE");
close(SE);
}
sub test_update_field {
my $self=shift;
my $odb=$self->get_odb();
my $global=$odb->fetch('/');
$self->assert(ref($global), "Failure getting / reference");
##
# Spaces at the end of string are chopped off at least by
# MySQL. Documented bug.
#
foreach my $text (q('"~!@#$%^&*_+=[]{}),
'()æù÷áÊÃÕË',
' Spaces .' ,
'Test Project') {
$global->put(project => $text);
my $got=$global->get('project');
$self->assert($got eq $text,
"Field update ('$text' != '$got')");
}
}
sub test_delete_field {
my $self=shift;
my $odb=$self->get_odb();
my $global=$odb->fetch('/');
$self->assert(ref($global), "Failure getting / reference");
$global->put(project => '123abc');
$global->delete('project');
my $got=$global->get('project');
$self->assert(defined($got) && $got eq '',
"Field is incorrect after delete");
}
sub test_fetch {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$self->assert($cust, 'Hash object fetch failed');
my $custlist=$odb->fetch('/Customers');
$self->assert($cust, 'List object fetch failed');
}
sub test_container_key {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$self->assert($cust, 'Hash object fetch failed');
my $ckey=$cust->container_key();
$self->assert($ckey eq 'c1',
"container_key() returned bad value ('$ckey'!='c1')");
}
sub test_defined {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$self->assert($cust, 'Hash object fetch failed');
$cust->put(name => 'aaaa');
$self->assert($cust->defined('name'),
"Method defined('name') returned false instead of true");
}
sub test_exists {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$self->assert($cust, 'Hash object fetch failed');
$self->assert($cust->exists('name'),
"Method exists('name') returned false instead of true");
$self->assert(!$cust->exists('nonexistent'),
"Method exists('nonexistent') returned true instead of false");
$self->assert($cust->exists('unique_id'),
"Method exists('unique_id') returned false instead of true");
}
sub test_keys {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$self->assert($cust, 'Hash object fetch failed');
my $keys=join(',',sort $cust->keys());
$self->assert($keys eq 'customer_id,name',
"Keys are wrong for customer ('$keys'!='customer_id,name')");
}
sub test_is_attached {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$self->assert($cust, 'Hash object fetch failed');
$self->assert($cust->is_attached(),
"Is_attached() returned false on attached object");
my $newcust=$odb->fetch('/Customers')->get_new();
$self->assert(! $newcust->is_attached(),
"Is_attached() returned true on detached object");
}
sub test_values {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$self->assert($cust, 'Hash object fetch failed');
$cust->add_placeholder(name => 'xxx',
type => 'text'
);
$cust->put(name => 'foo');
$cust->put(xxx => '123');
my %v;
@v{$cust->keys()}=$cust->values();
my $v=join(",",map { $v{$_} } sort keys %v);
$self->assert($v eq 'c1,foo,123',
"Values() returned wrong list ('$v'!='c1,foo,123')");
}
sub test_describe {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$cust->add_placeholder(name => 'xxx',
type => 'text',
maxlength => 123,
);
my $desc=$cust->describe('xxx');
$self->assert(ref($desc),
"Describe() did not return field description");
$self->assert($desc->{name} eq 'xxx',
"Describe() returned wrong name ($desc->{name}!='xxx')");
$self->assert($desc->{type} eq 'text',
"Describe() returned wrong type ($desc->{type}!='text')");
$self->assert($desc->{maxlength} eq 123,
"Describe() returned wrong maxlength ($desc->{maxlength}!='123')");
$self->assert($desc->{default} eq '',
"Describe() returned wrong default ($desc->{default})");
}
sub test_integer {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
foreach my $max (100, 100000, 100000000) {
$cust->add_placeholder(name => 'int',
type => 'integer',
minvalue => 20,
maxvalue => $max);
my $value=int($max/2);
$cust->put(int => $value);
my $got=$cust->get('int');
$self->assert($got == $value,
"Got not what was stored ($got!=$value)");
my $stored=1;
try {
$cust->put(int => $max+1);
}
otherwise {
$stored=0;
};
$self->assert(!$stored,
"Allowed to store value bigger then maxvalue (max=$max)");
$self->assert($cust->get('int') == $value,
"Value was corrupted by unsuccessful store (max=$max)");
$stored=1;
try {
$cust->put(int => $max);
}
otherwise {
$stored=0;
};
$self->assert($stored,
"Does not allow to store value equal to maxvalue (max=$max)");
$stored=1;
try {
$cust->put(int => 10);
}
otherwise {
$stored=0;
};
$self->assert(!$stored,
"Allowed to store value less then minvalue (max=$max)");
$self->assert($cust->get('int') == $max,
"Value was corrupted by unsuccessful store (max=$max)");
$cust->drop_placeholder('int');
}
}
sub test_real {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
foreach my $max (100, 1e20) {
$cust->add_placeholder(name => 'real',
type => 'real',
minvalue => 20,
maxvalue => $max);
my $value=$max/2;
$cust->put(real => $value);
my $got=$cust->get('real');
$self->assert($got == $value,
"Got not what was stored ($got!=$value)");
my $stored=1;
try {
$cust->put(real => $max*1.1);
}
otherwise {
$stored=0;
};
$self->assert(!$stored,
"Allowed to store value bigger then maxvalue (max=$max)");
$self->assert($cust->get('real') == $value,
"Value was corrupted by unsuccessful store (max=$max)");
$stored=1;
try {
$cust->put(real => $max);
}
otherwise {
$stored=0;
};
$self->assert($stored,
"Does not allow to store value equal to maxvalue (max=$max)");
$stored=1;
try {
$cust->put(real => 10);
}
otherwise {
$stored=0;
};
$self->assert(!$stored,
"Allowed to store value less then minvalue (max=$max)");
$self->assert($cust->get('real') == $max,
"Value was corrupted by unsuccessful store (max=$max)");
$cust->drop_placeholder('real');
}
my $clist=$odb->fetch('/Customers');
my $nc=$clist->get_new();
$nc->add_placeholder(name => 'real',
type => 'real');
$nc->put(real => 123.45);
$clist->put('new' => $nc);
$nc=$clist->get('new');
$self->assert(ref($nc),
"Can't get stored object with real field");
my $got=$nc->get('real');
$self->assert($got == 123.45,
"Got wrong real value ($got!=123.45)");
}
sub test_unique {
my $self=shift;
my $odb=$self->get_odb();
my $list=$odb->fetch('/Customers');
$list->destroy();
foreach my $type (qw(text integer real)) {
my $c=$list->get_new();
$c->add_placeholder(name => 'uf',
type => $type,
unique => 1);
$c->put(uf => 1);
$list->put(u1 => $c);
my $c1=$list->get('u1');
$self->assert(ref($c1),
"Can't get stored object");
$self->assert($c1->get('uf') == 1,
"Wrong value in the unique field of the first object (1)");
my $mistake;
stderr_stop();
try {
$list->put(u2 => $c);
$mistake=1;
} otherwise {
$mistake=0;
};
stderr_restore();
$self->assert(! $mistake,
"Succeded in putting the same object twice, 'unique' does not work");
$c->put(uf => 2);
$list->put(u2 => $c);
my $c2=$list->get('u2');
$self->assert(ref($c2),
"Can't get stored object");
$self->assert($c2->get('uf') == 2,
"Wrong value in the unique field of the first object (2)");
$c2->put(uf => 3);
$self->assert($c2->get('uf') == 3,
"Wrong value in the unique field of the first object (3)");
stderr_stop();
try {
$c1->put(uf => 3);
$mistake=1;
} otherwise {
$mistake=0;
};
stderr_restore();
$self->assert(! $mistake,
"Succeded in storing two equal values into unique field");
$self->assert($c1->get('uf') == 1,
"Unique field produced error and still stored second value");
$c->drop_placeholder('uf');
$list->destroy();
}
}
##
# Checking how 'unique' works for second level objects. The trick with
# them is that the field should be unique in the space of an enclosing
# container, but two containers can have identical properties.
#
sub test_unique_2 {
my $self=shift;
my $odb=$self->get_odb();
my $list=$odb->fetch('/Customers');
my $c1=$list->get('c1');
my $c2=$list->get('c2');
foreach my $type (qw(text integer real)) {
$c1->add_placeholder(
name => 'Orders',
type => 'list',
class => 'Data::Order',
key => 'order_id',
);
my $order=$c1->get('Orders')->get_new;
$order->add_placeholder(
name => 'foo',
type => $type,
unique => 1,
);
$order->put(foo => 1);
my $c1list=$c1->get('Orders');
my $c2list=$c2->get('Orders');
my $mistake;
stderr_stop();
try {
$c1list->put(o1 => $order);
$c2list->put(o1 => $order);
$mistake=0;
}
otherwise {
$mistake=1;
};
stderr_restore();
$self->assert(! $mistake,
"Can't put the same object into two different parents' lists");
stderr_stop();
try {
$c1list->put(o2 => $order);
$mistake=1;
}
otherwise {
$mistake=0;
};
stderr_restore();
$self->assert(! $mistake,
"Put the same object twice (type=$type), 'unique' does not work on the second level");
$order->put(foo => 2);
$c2list->put(o2 => $order);
stderr_stop();
try {
$c2list->put(o1 => $order);
$mistake=1;
} otherwise {
$mistake=0;
};
stderr_restore();
$self->assert(! $mistake,
"Put the same object twice (type=$type), replacement");
$self->assert(! $c1list->exists('o2'),
"Got o2 from the c1list");
$self->assert($c1list->get('o1')->get('foo') eq '1',
"Got wrong value from c1list");
$self->assert($c2list->get('o1')->get('foo') eq '1',
"Got wrong value from c2list/o2");
$self->assert($c2list->get('o2')->get('foo') eq '2',
"Got wrong value from c2list/o2");
$order->drop_placeholder('foo');
$c1->drop_placeholder('Orders');
}
}
sub test_get_multi {
my $self=shift;
my $odb=$self->get_odb();
my $cust=$odb->fetch('/Customers/c1');
$self->assert($cust, 'Hash object fetch failed');
$cust->add_placeholder(name => 'xxx',
type => 'text'
);
$cust->put(name => 'foo', xxx => '123');
my ($name_1,$xxx_1)=$cust->get(qw(name xxx));
my ($xxx_2,$name_2)=$cust->get(qw(xxx name));
$self->assert($name_1 eq 'foo',
"test_get_multi: Got wrong name_1");
$self->assert($xxx_1 eq '123',
"test_get_multi: Got wrong xxx_1");
$self->assert($xxx_1 eq $xxx_2 && $name_1 eq $name_2,
"test_get_multi: Order of stuff is wrong on second call");
my $global=$odb->fetch('/');
my @val=$global->get(sort $global->keys);
$self->assert(@val == 2,
"test_get_multi: Global returned wrong number of values");
$self->assert(ref($val[0]) && $val[0]->objtype eq 'List',
"test_get_multi: Global did not return list reference");
my $nc=$odb->fetch('/Customers')->get_new();
$nc->put({ name => 'abc', xxx => 'zzz'});
my ($xxx,$name)=$nc->get(qw(xxx name));
$self->assert($name eq 'abc',
"test_get_multi: Got wrong name");
$self->assert($xxx eq 'zzz',
"test_get_multi: Got wrong xxx");
}
##
# Checks how translation from undef to default values work. Undefs are
# not supported by XAO::FS and therefore are never returned.
#
sub test_null {
my $self=shift;
my $odb=$self->get_odb();
my $clist=$odb->fetch('/Customers');
$self->assert($clist, 'List object fetch failed');
my $cust=$clist->get('c1');
$self->assert($cust, 'Hash object fetch failed');
$cust->add_placeholder(name => 'text',
type => 'text',
);
$cust->add_placeholder(name => 'text2',
type => 'text',
default => 'test',
);
$cust->add_placeholder(name => 'integer',
type => 'integer',
);
$cust->add_placeholder(name => 'real',
type => 'real',
);
$cust->add_placeholder(name => 'int1',
type => 'integer',
default => 10000,
);
$cust->add_placeholder(name => 'int2',
type => 'integer',
minvalue => 1000,
);
$cust->add_placeholder(name => 'real2',
type => 'real',
minvalue => 256,
);
my %matrix=(
t1 => {
name => 'text',
default => '',
},
t2 => {
name => 'integer',
default => 0,
},
t3 => {
name => 'int1',
default => 10000,
},
t4 => {
name => 'int2',
default => 1000,
},
t5 => {
name => 'real',
default => 0,
},
t6 => {
name => 'real2',
default => 256,
},
t7 => {
name => 'text2',
default => 'test',
},
);
foreach my $test (map { $matrix{$_} } sort keys %matrix) {
my $name=$test->{name};
my $expect=$test->{default};
my $c=$clist->get('c2');
my $desc=$c->describe($name);
$self->assert(defined($desc->{default}),
"Default value not set in describe() for $name");
$self->assert($desc->{default} eq $expect,
"Default value is wrong for $name (got '$desc->{default}', expected '$expect')");
my $got=$c->get($name);
$self->assert(defined($got),
"Got 'undef' for name=$name (initial)");
$self->assert($got eq $expect,
"Expect $expect, got $got for name=$name (initial)");
$c->put($name => 12345);
$c=$clist->get('c2');
$c->delete($name);
$got=$c->get($name);
$self->assert(defined($got),
"Got 'undef' for name=$name (deleted)");
$self->assert($got eq $expect,
"Expect $expect, got $got for name=$name (deleted)");
$c->put($name => undef);
$c=$clist->get('c2');
$got=$c->get($name);
$self->assert(defined($got),
"Got 'undef' for name=$name (put undef)");
$self->assert($got eq $expect,
"Expect $expect, got $got for name=$name (put undef)");
$c->put($name => $expect);
$c=$clist->get('c2');
$got=$c->get($name);
$self->assert(defined($got),
"Got 'undef' for name=$name (put default)");
$self->assert($got eq $expect,
"Expect $expect, got $got for name=$name (put default)");
##
# Now the same on detached object
#
$c=$clist->get_new;
$got=$c->get($name);
$self->assert(defined($got),
"Got 'undef' for name=$name (initial, detached)");
$self->assert($got eq $expect,
"Expect $expect, got $got for name=$name (initial, detached)");
$c->put($name => 12345);
$c->delete($name);
$got=$c->get($name);
$self->assert(defined($got),
"Got 'undef' for name=$name (deleted, detached)");
$self->assert($got eq $expect,
"Expect $expect, got $got for name=$name (deleted, detached)");
$c->put($name => undef);
$got=$c->get($name);
$self->assert(defined($got),
"Got 'undef' for name=$name (put undef, detached)");
$self->assert($got eq $expect,
"Expect $expect, got $got for name=$name (put undef, detached)");
$c->put($name => $expect);
$got=$c->get($name);
$self->assert(defined($got),
"Got 'undef' for name=$name (put default, detached)");
$self->assert($got eq $expect,
"Expect $expect, got $got for name=$name (put default, detached)");
}
}
1;