use strict;
use lib "t";
use Tangram qw(:compat_quiet);
use Tangram::RawDate;
use Tangram::RawTime;
use Tangram::RawDateTime;
use Tangram::FlatArray;
use Tangram::FlatHash;
use Tangram::PerlDump;
use Tangram::Storable;
use Tangram::IDBIF;
package Springfield;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %id @kids @opinions $no_date_manip);
eval 'use Tangram::Type::Date::Manip';
$no_date_manip = $@;
@ISA = qw( Exporter );
@EXPORT = qw( &optional_tests $schema testcase &leaktest &leaked &test &begin_tests &tests_for_dialect $dialect $cs $user $passwd stdpop %id @kids @opinions);
@EXPORT_OK = @EXPORT;
use vars qw($cs $user $passwd $dialect $vendor $schema);
use vars qw($no_tx $no_subselects $table_type);
use lib "t";
use DBConfig;
{
my ($tx, $subsel, $ttype);
($cs, $user, $passwd) = DBConfig->cparm;
$no_tx = DBConfig->no_tx;
$no_subselects = DBConfig->no_subselects;
$table_type = DBConfig->table_type;
$vendor = DBConfig->vendor;
$dialect = DBConfig->dialect;
}
sub list_if {
shift() ? @_ : ()
}
$schema =
( {
#set_id => sub { my ($obj, $id) = @_; $obj->{id} = $id },
#get_id => sub { shift()->{id} },
sql =>
{
cid_size => 3,
# Allow InnoDB style tables
( $table_type ? ( table_type => $table_type ) : () ),
dumper => "Data::Dumper",
},
class_table => 'Classes',
classes =>
[
Person =>
{
abstract => 1,
fields =>
{
string => { colour => undef,
},
},
},
NaturalPerson =>
{
bases => [ qw( Person ) ],
fields =>
{
string =>
{
firstName => undef,
name => undef,
},
int => [ qw( age person_id ) ], # ks.perl@kurtstephens.com 2003/10/16
ref =>
{
partner => undef,
credit => { aggreg => 1 },
},
# only test the RAW columns with PostgreSQL and MySQL
($vendor =~ m/^(Pg|mysql)/
?
(rawdate => [ qw( birthDate ) ],
rawtime => [ qw( birthTime ) ],
rawdatetime => [ qw( birth ) ],
):()),
($no_date_manip ? () : ( dmdatetime => [ qw( incarnation ) ] )),
#($no_time_piece ? () : ( timepiece => [ qw( timepiece ) ] )),
#($no_date_manip ? () : ( dmdatetime => [ qw( incarnation ) ] )),
array =>
{
children =>
{
class => 'NaturalPerson',
table => 'a_children',
aggreg => 1,
},
belongings =>
{
class => 'Item',
aggreg => 1,
deep_update => 1
},
a_opinions =>
{
class => 'Opinion',
table => 'a_opinions',
}
},
ihash =>
{
ih_opinions =>
{
class => 'Opinion',
back => "ih_parent",
}
},
hash =>
{
h_opinions =>
{
class => 'Opinion',
table => 'h_opinions',
}
},
iarray =>
{
ia_children =>
{
class => 'NaturalPerson',
coll => 'ia_ref',
slot => 'ia_slot',
back => 'ia_parent',
aggreg => 1,
},
ia_opinions =>
{
class => 'Opinion',
}
},
set =>
{
s_children =>
{
class => 'NaturalPerson',
table => "s_children", #__
aggreg => 1,
},
#s_parents =>
#{
#class => 'NaturalPerson',
#table => 's_children',
#coll => "item",
#item => "coll",
#},
s_opinions =>
{
class => 'Opinion',
table => 's_opinions', #__
}
},
iset =>
{
is_children =>
{
class => 'NaturalPerson',
coll => 'is_ref',
slot => 'is_slot',
back => 'is_parent',
aggreg => 1,
},
is_opinions =>
{
class => 'Opinion',
}
},
flat_array => [ qw( interests ) ],
flat_hash => [ qw( opinions ) ],
perl_dump => [ qw( brains ) ],
( $vendor !~ m/^Peegee$/
? (storable => [ qw( thought ) ])
: () ),
},
},
Opinion =>
{
fields =>
{
string => [ qw( statement ) ],
},
},
LegalPerson =>
{
bases => [ qw( Person ) ],
table => "Person",
fields =>
{
string =>
[ qw( name ) ],
ref =>
{
manager => { null => 1 }
},
},
},
EcologicalRisk =>
{
abstract => 1,
fields =>
{
int => [ qw( curies ) ],
},
},
NuclearPlant =>
{
bases => [ qw( LegalPerson EcologicalRisk ) ],
fields =>
{
array =>
{
employees =>
{
class => 'NaturalPerson',
table => 'employees'
}
},
},
},
Credit =>
{
fields =>
{
#int => { limit => { col => 'theLimit' } },
int => { limit => 'theLimit' },
}
},
Item =>
{
fields =>
{
string => [ qw(name) ],
ref =>
{
owner => { deep_update => 1 }
}
}
},
Faerie => {
fields =>
{ idbif => { -poof => # there goes another one!
undef
# { dumper => "Storable" }
},
string => [ qw(name) ],
},
},
FaerieHairy => {
fields =>
{
string => [ qw(name) ],
idbif => { friends => undef,
enemies => undef,
#-options => { dumper => "Storable" },
} },
},
Sprite => {
table => qw(Faerie),
bases => [ qw(Faerie) ],
fields => { string => [ qw(foo) ], },
},
Nymph => {
table => qw(FaerieHairy),
bases => [ qw(FaerieHairy) ],
fields => { idbif => [ qw(buddies) ],
},
},
],
} );
if ( $ENV{"NORMALIZE_TEST"} ) {
$schema->{normalize} =
sub {
local($_)=shift;
print STDERR "topic is $_\n";
s/NaturalPerson/NP/;
s/$/_n/;
return $_;
};
}
$schema = Tangram::Schema->new($schema);
sub connect
{
my $schema = shift || $Springfield::schema;
my $opts = shift || {};
my $storage = $dialect->connect($schema, $cs, $user, $passwd, $opts) || die;
$no_tx = $storage->{no_tx} unless defined $no_tx;
$no_subselects = $storage->{no_subselects};
return $storage;
}
sub empty
{
my $storage = shift || Springfield::connect;
my $schema = shift || $Springfield::schema;
my $conn = $storage->{db};
foreach my $classdef (values %{ $schema->{classes} }) {
$conn->do("DELETE FROM $classdef->{table}") or die
unless $classdef->{stateless};
}
$conn->do('DELETE FROM a_children');
$conn->do('DELETE FROM s_children');
}
sub connect_empty
{
my $schema = shift || $Springfield::schema;
my $storage = Springfield::connect($schema);
empty($storage, $schema);
return $storage;
}
use vars qw( $test );
sub begin_tests
{
print "1..", shift, "\n";
$test = 1;
}
sub _caller
{
my @caller = caller(1);
return "$caller[1] line $caller[2]";
}
sub test
{
my $ok = shift;
print 'not ' unless $ok;
print 'ok ', $test++;
print " - "._caller()."\n";
my ($fun, $file, $line) = caller;
print "$file($line) : error\n" unless $ok;
}
*testcase = \&test;
sub leaktest
{
if ($SpringfieldObject::pop == 0)
{
print "ok $test - leaktest "._caller()."\n";
}
else
{
my ($fun, $file, $line) = caller;
print "not ok $test - leaktest "._caller()."\n";
print "$file($line) : error: $SpringfieldObject::pop object(s) leaked\n";
}
$SpringfieldObject::pop = 0;
++$test;
}
sub leaked
{
return $SpringfieldObject::pop;
}
sub tx_tests
{
my ($tests, $code) = @_;
if ($no_tx)
{
print STDERR "tests $test-", $test + $tests - 1, " (transactions) skipped on this platform ";
test(1) while $tests--;
}
else
{
&$code;
}
}
sub optional_tests
{
my ($what, $proceed, $tests) = @_;
$test ||= 1;
unless ($proceed)
{
print STDERR "tests $test-", $test + $tests - 1,
" ($what) skipped on this platform ";
test(1) while $tests--;
}
return $proceed;
}
sub tests_for_dialect {
my %dialect;
@dialect{@_} = ();
return if exists $dialect{ (split ':', $cs)[1] };
begin_tests(1);
optional_tests($dialect, 0, 1);
exit;
}
#use Data::Dumper;
#print Dumper $schema;
#deploy;
@kids = qw( Bart Lisa Maggie );
sub stdpop
{
my $storage = Springfield::connect_empty;
my $children = shift || "children";
$NaturalPerson::person_id = 0; # ks.perl@kurtstephens.com 2003/10/16
my @children = (map { NaturalPerson->new( firstName => $_ ) }
@kids);
$children[0]->{age} = 10;
$children[1]->{age} = 8;
$children[2]->{age} = 1;
@id{ @kids } = $storage->insert( @children );
# *cough* hack *cough*
main::like("@id{@kids}", qr/^\d+ \d+ \d+$/, "Got ids back OK")
if defined &main::like;
my %ops = ( "beer" => Opinion->new(statement => "good"),
"donuts" => Opinion->new(statement => "mmm.."),
"heart disease" =>
Opinion->new(statement => "Heart What?"));
@opinions = map { $_->{statement} } values %ops;
my $homer;
{
$homer = NaturalPerson->new
(
age => 38,
firstName => 'Homer',
($children =~ m/children/
? ($children =~ m/s_/
? ( $children => Set::Object->new(@children) )
: ( $children => [ @children ] ) )
: () ),
($children =~ m/opinion/
? ($children =~ m/h_/
? ($children => { %ops })
: ($children =~ m/a_/
? ($children => [ values %ops ])
: ($children => Set::Object->new( values %ops ) )
)
)
: ()
)
);
}
$id{Homer} = $storage->insert($homer);
main::isnt($id{Homer}, 0, "Homer inserted OK")
if defined &main::isnt;
my $marge = NaturalPerson->new( firstName => 'Marge',
age => 37,
);
# cannot have >1 parent with a one to many relationship!
if ($children =~ m/children/) {
if ($children =~ m/^i/) {
} elsif ($children =~ m/s_/) {
$marge->{$children} = Set::Object->new(@children);
} else {
$marge->{$children} = [ @children ]
}
}
$id{Marge} = $storage->insert($marge);
main::isnt($id{Marge}, 0, "Marge inserted OK")
if defined &main::isnt;
my $abraham = NaturalPerson->new( firstName => 'Abraham',
age => 62,
($children =~ m/children/
? ($children =~ m/s_/
? ( $children => Set::Object->new($homer) )
: ( $children => [ $homer ] ) )
: () ),
);
$id{Abraham} = $storage->insert($abraham);
$storage->disconnect;
}
package SpringfieldObject;
use vars qw( $pop $VERBOSE );
sub new
{
my $pkg = shift;
++$pop;
my $foo = bless { $pkg->defaults, @_ }, $pkg;
print STDERR "# I am alive! $foo\n"
if $VERBOSE;
return $foo;
}
sub defaults
{
return ();
}
sub DESTROY
{
# die if exists shift->{id};
print STDERR "# I am dying! $_[0]\n"
if $VERBOSE;
--$pop;
}
package Person;
use vars qw(@ISA);
@ISA = qw( SpringfieldObject );
sub as_string
{
die 'subclass responsibility';
}
#use overload '""' => sub { shift->as_string }, fallback => 1;
package NaturalPerson;
use vars qw(@ISA);
@ISA = qw( Person );
# BEGIN ks.perl@kurtstephens.com 2003/10/16
our $person_id = 0;
# END ks.perl@kurtstephens.com 2003/10/16
sub defaults
{
'person_id' => ++ $person_id, # ks.perl@kurtstephens.com 2003/10/16
a_children => [], ia_children => [],
s_children => Set::Object->new, is_children => Set::Object->new,
h_opinions => {}
}
sub as_string
{
my ($self) = @_;
local $^W; # why? get use of undefined value otherwise
exists($self->{name}) && exists($self->{firstName}) && "$self->{firstName} $self->{name}"
|| $self->{firstName} || $self->{name}
}
package LegalPerson;
use vars qw(@ISA);
@ISA = 'Person';
sub as_string
{
return shift->{name};
}
package NuclearPlant;
use vars qw(@ISA);
@ISA = qw( LegalPerson );
package Opinion;
use vars qw(@ISA);
@ISA = qw( SpringfieldObject );
package Credit;
use vars qw(@ISA);
@ISA = qw( SpringfieldObject );
package Item;
use vars qw(@ISA);
@ISA = qw( SpringfieldObject );
package Faerie;
use vars qw(@ISA);
@ISA = qw( SpringfieldObject );
package FaerieHairy;
use vars qw(@ISA);
@ISA = qw( SpringfieldObject );
1;