Tangram-2.12/0000755000175000017500000000000012605757356011545 5ustar samvsamvTangram-2.12/t/0000755000175000017500000000000012605757356012010 5ustar samvsamvTangram-2.12/t/no_tests.t0000644000175000017500000000006012605613635014016 0ustar samvsamv print "1..0 # SKIP: TEST SUITE IS DISABLED\n"; Tangram-2.12/t/springfield/0000755000175000017500000000000012605757356014316 5ustar samvsamvTangram-2.12/t/springfield/07-weakref.t0000644000175000017500000000465712605613635016356 0ustar samvsamv# -*- cperl -*- use strict; use lib 't/springfield'; use Springfield; use Data::Lazy; use Scalar::Util qw(refaddr); BEGIN { eval "use Scalar::Util"; eval "use WeakRef" if $@; if ($@) { eval 'use Test::More skip_all => "No WeakRef / Scalar::Util"'; exit; } else { eval 'use Test::More tests => 4;'; } } my $VERBOSE; if ( @ARGV and $ARGV[0] eq "-v" ) { $VERBOSE = 1; $SpringfieldObject::VERBOSE = 1; } # $Tangram::TRACE = \*STDOUT; my $tests = 3; { my $storage = Springfield::connect_empty; $storage->insert( NaturalPerson->new( firstName => 'Homer' )); is(leaked, 0, "WeakRef works"); $storage->disconnect(); } { my $storage = Springfield::connect; { my ($homer) = $storage->select('Person'); is($SpringfieldObject::pop, 1, "Objects not lost until they fall out of scope"); } is(leaked, 0, "WeakRef still works"); $storage->disconnect(); } sub sameid { my $obj; for (1..2) { $obj = {}; diag("got ".sprintf("0x%.8x",refaddr($obj)) .", looking for ".sprintf("0x%.8x",$_[0]||0)) if $VERBOSE; last if refaddr($obj) == ($_[0] ||= refaddr($obj)); $obj = undef; } $obj; } sub homer { my ($homer) = $_[0]->select('Person'); return $homer; } SKIP: { my $storage = Springfield::connect; my ($sameid,$refaddr, $test) = (undef, 0, undef); { homer($storage); } $storage->{schema}{make_object} = sub { my $x = $sameid; bless $x, (shift); $SpringfieldObject::pop++; return $sameid; }; diag("leaked is: ".leaked) if $VERBOSE; # note - this loop is fragile, but worksforme on perl 5.8.4, Ubuntu # hoary on amd64. Reports of other successes welcome. LOOP: for my $x ( 1..5 ) { { $refaddr = 0 unless $x > 2; diag("undef(\$sameid = $sameid)") if $VERBOSE; undef($sameid); undef($test); diag("done undef") if $VERBOSE; $test = sameid($refaddr) or next; tie $sameid, 'Data::Lazy' => sub { $test }; diag("test is: ".$test) if $VERBOSE; diag("sameid is: ".$sameid) if $VERBOSE; if ( $x <= 2 ) { homer($storage); } else { diag("wohoo! I got ".sprintf("0x%.8x",refaddr($sameid) )) if $VERBOSE; diag ("calling last") if $VERBOSE; last LOOP; } } diag("leaked is: ".leaked) if $VERBOSE; } skip "failed to get an object with the same refid", 1 unless $sameid; is($storage->id($sameid), undef, "hmm!"); $storage->disconnect(); } Tangram-2.12/t/springfield/22-flathash.t0000644000175000017500000000653212605613635016513 0ustar samvsamv use strict; use lib 't/springfield'; use Springfield; sub compare_hash { my ($a,$b) = @_; foreach (keys %{$a}) { return undef unless ($a->{$_} eq $b->{$_}); } foreach (keys %{$b}) { return undef unless ($a->{$_} eq $b->{$_}); } 1; } Springfield::begin_tests(17); #$Tangram::TRACE = \*STDOUT; { my $storage = Springfield::connect_empty(); my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', opinions => { work => 'bad', food => 'good', beer => 'better' } ); $storage->insert($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, { work => 'bad', food => 'good', beer => 'better' })); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); $homer->{opinions}->{'sex'} = 'good'; $storage->update($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, { work => 'bad', food => 'good', beer => 'better', sex => 'good' })); delete $homer->{opinions}->{work}; $storage->update($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, { food => 'good', beer => 'better', sex => 'good' })); $homer->{opinions}->{'sex'} = 'fun'; $storage->update($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, { food => 'good', beer => 'better', sex => 'fun' })); delete $homer->{opinions}; $storage->update($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, {})); $homer->{opinions} = { work => 'bad', food => 'good', beer => 'better' }; $storage->update($homer); $storage->disconnect(); } leaktest(); # prefetch { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); $storage->prefetch($remote, 'opinions'); my ($homer) = $storage->select($remote, $remote->{firstName} eq 'Homer'); { local ($storage->{db}); testcase(compare_hash($homer->{opinions}, { work => 'bad', food => 'good', beer => 'better' })); } $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); $storage->prefetch($remote, 'opinions', $remote->{firstName} eq 'Homer'); my ($homer) = $storage->select($remote, $remote->{firstName} eq 'Homer'); { local ($storage->{db}); testcase(compare_hash($homer->{opinions}, { work => 'bad', food => 'good', beer => 'better' })); } $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); $storage->erase( $storage->select('NaturalPerson')); Springfield::test( 0 == $storage->connection()->selectall_arrayref("SELECT COUNT(*) FROM NaturalPerson_opinions")->[0][0] ); $storage->disconnect(); } Tangram-2.12/t/springfield/38-stateless.t0000644000175000017500000000152512605613635016734 0ustar samvsamv # wtf is this testing anyway? use strict; use lib 't/springfield'; use Springfield; Springfield::begin_tests(5); my $plant_id; { my $storage = Springfield::connect_empty; $plant_id = $storage->insert( NuclearPlant->new( employees => [ NaturalPerson->new( firstName => 'Homer' ) ] ) ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $plant = $storage->load( $plant_id ); Springfield::test( @{ $plant->{employees} } == 1 && $plant->{employees}[0]{firstName} eq 'Homer' ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my ($plant) = $storage->select( 'NuclearPlant' ); Springfield::test( @{ $plant->{employees} } == 1 && $plant->{employees}[0]{firstName} eq 'Homer' ); $storage->disconnect; } Springfield::leaktest; 1; Tangram-2.12/t/springfield/02-cursor.t0000644000175000017500000001133212605613635016226 0ustar samvsamv use strict; use lib "t/springfield"; use Springfield; my @kids = qw( Bart Lisa Maggie ); my @population = sort qw( Homer Marge ), @kids; my $children = 'children'; sub NaturalPerson::children { my ($self) = @_; return wantarray ? @{ $self->{$children} } : join(' ', map { $_->{firstName} } @{ $self->{$children} } ) } Springfield::begin_tests(15); { my $storage = Springfield::connect_empty; my @children = map { NaturalPerson->new( firstName => $_, name => 'Simpson' ) } @kids; my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', $children => [ @children ] ); my $marge = NaturalPerson->new(firstName => 'Marge', name => 'Simpson', $children => [ @children ] ); $homer->{partner} = $marge; $marge->{partner} = $homer; $storage->insert( $homer, $marge ); delete $homer->{partner}; $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $cursor = $storage->cursor( 'NaturalPerson' ); my @results; while (my $person = $cursor->current()) { push @results, $person->{firstName}; Springfield::test( $person->children eq "@kids" ) if $person->{firstName} eq 'Homer'; $cursor->next(); } @results = sort @results; Springfield::test( "@results" eq "@population" ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $cursor1 = $storage->cursor( 'NaturalPerson' ); my $cursor2 = $storage->cursor( 'NaturalPerson' ); my (@r1, @r2); while ($cursor1->current()) { my $p1 = $cursor1->current(); my $p2 = $cursor2->current(); push @r1, $p1->{firstName}; push @r2, $p2->{firstName}; Springfield::test( $p1->children eq "@kids" ) if $p1->{firstName} eq 'Homer'; Springfield::test( $p2->children eq "@kids" ) if $p2->{firstName} eq 'Marge'; $cursor1->next(); $cursor2->next(); } @r1 = sort @r1; @r2 = sort @r2; Springfield::test( "@r1" eq "@population" && "@r2" eq "@population" ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; $storage->insert( NaturalPerson->new(firstName => 'Montgomery', name => 'Burns' ) ); $storage->disconnect; } { my $storage = Springfield::connect; my $remote = $storage->remote('NaturalPerson'); my @results = $storage->select($remote, order => [ $remote->{firstName}, $remote->{name} ] ); @results = map { "$_->{firstName} $_->{name}"} @results; Springfield::test( "@results\n" eq <disconnect; } { my $storage = Springfield::connect; my $remote = $storage->remote('NaturalPerson'); my @results = $storage->select($remote, filter => $remote->{name} eq 'Simpson', order => [ $remote->{firstName}, $remote->{name} ] ); @results = map { "$_->{firstName} $_->{name}"} @results; Springfield::test( "@results\n" eq <disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my ($person, $partner) = $storage->remote(qw( NaturalPerson NaturalPerson )); my $cursor = $storage->cursor($person, filter => $person->{partner} == $partner, order => [ $partner->{firstName} ], retrieve => [ $partner->{firstName}, $partner->{name} ] ); my @results; while (my $p = $cursor->current()) { push @results, $p->{firstName}, $cursor->residue(); $cursor->next(); } # print "@results\n"; Springfield::test( "@results" eq 'Marge Homer Simpson Homer Marge Simpson'); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my ($person, $partner) = $storage->remote(qw( NaturalPerson NaturalPerson )); my $cursor = $storage->cursor($person, filter => $person->{partner} == $partner, # here we're ordering by an unselected foreign column; MySQL doesn't # mind, some other RDBMS' apparently do. # This extra column will end up in the $cursor->residue(); order => [ $partner->{firstName} ], ); my @results; while (my $p = $cursor->current()) { push @results, $p->{firstName}, $cursor->residue(); $cursor->next(); } # print "@results\n"; Springfield::test( "@results" eq 'Marge Homer Homer Marge'); $storage->disconnect; } Springfield::leaktest; #{ # my $storage = Springfield::connect; # my ($person) = $storage->remote(qw( NaturalPerson )); # my $cursor = $storage->cursor($person, limit => 1); # Springfield::test( $cursor->current() && !$cursor->next()); # $storage->disconnect; #} #Springfield::leaktest; Tangram-2.12/t/springfield/41-storable.t0000644000175000017500000000275212605613635016535 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 4; use_ok("Tangram::Dump"); use Data::Dumper; use lib 't/springfield'; use Springfield; use Set::Object qw(is_overloaded blessed); SKIP:{ #skip "Storable broken on Pg - see lib/Tangram/Pg.pod", 3 #if $Springfield::vendor eq "Pg"; my $homer_id; { my $storage = Springfield::connect_empty(); my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', ); my $marge = NaturalPerson->new( firstName => 'Marge', name => 'Simpson' ); $homer->{partner} = $marge; $marge->{partner} = $homer; $homer_id = $storage->insert($homer); delete $homer->{partner}; delete $marge->{partner}; } is(leaked, 0, "leaktest"); # now test putting it in the database... { my $storage = Springfield::connect; my $homer = $storage->load($homer_id); $homer->{thought} = { me => $homer, marge => $homer->{partner}, beer => "good", beer_from => "fridge", beer_fetched_by => \\$homer->{partner}, # fails leaktest ... more investigation required #family => Set::Object->new($homer, #$homer->{partner}) }; $storage->update($homer); delete $homer->{partner}; delete $homer->{thought}; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($homer_id); my $marge = $homer->{partner}; is($homer->{thought}->{marge}, $marge, "Storable can store Tangram objects!"); } } Tangram-2.12/t/springfield/39-save.t0000644000175000017500000000472112605613635015665 0ustar samvsamv # the functionality this test tests can probably be moved into type # specific tests use lib 't/springfield'; use Springfield; my %id; Springfield::begin_tests(4); { $storage = Springfield::connect_empty; my $bart = NaturalPerson->new( firstName => 'Bart' ); $bart->{belongings} = [ Item->new( name => 'Skateboard', owner => $bart ), Item->new( name => 'Bike', owner => $bart ) ]; $id{Bart} = $storage->insert($bart); $storage->disconnect(); } #Springfield::leaktest; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); Springfield::test( $bart && $bart->{belongings}->[0]->{name} eq 'Skateboard' && $bart->{belongings}->[1]->{name} eq 'Bike'); $storage->disconnect(); } #Springfield::leaktest; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); push @{$bart->{belongings}}, Item->new( name => 'Sneakers', owner => $bart); $storage->update($bart); $storage->disconnect(); } #Springfield::leaktest; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); Springfield::test( $bart && $bart->{belongings}->[0]->{name} eq 'Skateboard' && $bart->{belongings}->[1]->{name} eq 'Bike' && $bart->{belongings}->[2]->{name} eq 'Sneakers'); $storage->disconnect(); } #Springfield::leaktest; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); $bart->{belongings}->[0]->{name} = 'T-shirt'; $storage->update($bart); $storage->disconnect(); } #Springfield::leaktest; my $export_id; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); $export_id = $storage->export_object($bart); Springfield::test( $bart && $bart->{belongings}->[0]->{name} eq 'T-shirt' && $bart->{belongings}->[1]->{name} eq 'Bike' && $bart->{belongings}->[2]->{name} eq 'Sneakers'); $storage->disconnect(); } { $storage = Springfield::connect(); my $bart = $storage->import_object("NaturalPerson", $export_id); Springfield::test( $bart && $bart->{belongings}->[0]->{name} eq 'T-shirt' && $bart->{belongings}->[1]->{name} eq 'Bike' && $bart->{belongings}->[2]->{name} eq 'Sneakers'); $storage->disconnect(); } #{ # $storage = Springfield::connect_empty; # my $bart = NaturalPerson->new( firstName => 'Bart' ); # $id{Bart} = $storage->insert($bart); # Springfield::empty($storage); # eval { $storage->update($bart) }; # Springfield::test($@); # $storage->disconnect(); #} #Springfield::leaktest; Tangram-2.12/t/springfield/35-hash.t0000644000175000017500000000301412605613635015640 0ustar samvsamv# -*- perl -*- use strict; use lib 't/springfield'; use Springfield; use Test::More tests => 4; use vars qw( $intrusive ); my $opinions = $intrusive ? 'ih_opinions' : 'h_opinions'; (my $other = $opinions) =~ s{^(i)?}{($1 ? "" : "i")}e; #$Tangram::TRACE = \*STDOUT; sub graph { my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', $opinions => { work => Opinion->new(statement => 'bad'), food => Opinion->new(statement => 'good'), beer => Opinion->new(statement => 'better') }, # this is for is_deeply... $other => undef, ); } { my $storage = Springfield::connect_empty(); my $homer = graph(); $storage->insert($homer); $storage->disconnect(); } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); # Test::More can be awfully pedantic at times :) my $homer_eg = graph(); my $opinions_h = $homer_eg->{$opinions}; my $ih_parent; if ($intrusive) { $ih_parent = $homer_eg; } while (my($k,$v)= each %$opinions_h) { $v->{ih_parent} = $ih_parent; } is_deeply([ sort keys %{ $homer->{$opinions}} ], [ sort keys %{$opinions_h} ], "Hash returned intact"); is_deeply([ sort map { $_->{statement} } values %{ $homer->{$opinions}} ], [ sort map { $_->{statement} } values %{ $opinions_h } ], "Hash returned intact"); # smash circular references... while (my($k,$v)= each %$opinions_h) { $v->{ih_parent} = undef; } $storage->disconnect(); } is(leaked, 0, "leaktest"); Tangram-2.12/t/springfield/80-mi.t0000644000175000017500000000143312605613635015325 0ustar samvsamv use strict; use lib "t/springfield"; use Springfield; Springfield::begin_tests(12); { my $storage = Springfield::connect_empty; $storage->insert( NuclearPlant->new( name => 'Springfield Nuclear Power Plant', curies => 1_000_000 ) ); $storage->disconnect(); } sub mi_test { my $base = shift; { my $storage = Springfield::connect; my ($plant) = $storage->select( $base ); Springfield::test( $plant ); Springfield::test( exists( $plant->{name} ) && $plant->{name} eq 'Springfield Nuclear Power Plant' ); Springfield::test( exists( $plant->{curies} ) && $plant->{curies} == 1_000_000 ); $storage->disconnect(); } Springfield::leaktest; } mi_test( 'NuclearPlant' ); mi_test( 'Person' ); mi_test( 'EcologicalRisk' ); Tangram-2.12/t/springfield/31-set.t0000644000175000017500000001622412605613635015513 0ustar samvsamv# -*- perl -*- use strict; use lib 't/springfield'; use Springfield qw(%id); use vars qw( $intrusive ); my $children = $intrusive ? 'is_children' : 's_children'; my @kids = qw( Bart Lisa Maggie ); sub NaturalPerson::children { my ($self) = @_; my @children = sort { $a->{firstName} cmp $b->{firstName} } $self->{$children}->members; return wantarray ? @children : join(' ', map { $_->{firstName} } @children ); } sub marge_test { my $storage = shift; Springfield::test( $intrusive || $storage->load( $id{Marge} )->children eq 'Bart Lisa Maggie' ); } sub stdpop { #local($Tangram::TRACE) = \*STDERR; my $storage = Springfield::connect_empty; my @children = map { NaturalPerson->new( firstName => $_ ) } @kids; @id{ @kids } = $storage->insert( @children ); # my $homer = NaturalPerson->new( firstName => 'Homer', $children => Set::Object->new( @children ) ); $id{Homer} = $storage->insert($homer); # my $marge = NaturalPerson->new( firstName => 'Marge' ); $marge->{$children} = Set::Object->new( @children ) unless $intrusive; $id{Marge} = $storage->insert($marge); # $storage->disconnect; ##<>; } Springfield::begin_tests(43); stdpop(); Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $homer->{$children}->remove( $storage->load( $id{Bart} ) ); $storage->update( $homer ); $storage->disconnect; } ############################################### # insert { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; Springfield::test( $homer->children eq 'Lisa Maggie' ); marge_test( $storage ); $homer->{$children}->clear(); $storage->update($homer); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; Springfield::test( $homer->children eq '' ); marge_test( $storage ); my $bart; $homer->{$children}->insert ( $bart = ($intrusive ? NaturalPerson->new(firstName => "Bart") : $storage->load($id{Bart}) )); $storage->update($homer); $id{Bart} = $storage->id($bart); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; Springfield::test( $homer->children eq 'Bart' ); marge_test( $storage ); my ($lisa, $maggie); $homer->{$children}->insert ( ($lisa, $maggie) = ($intrusive ? ( map { NaturalPerson->new(firstName => $_) } qw( Lisa Maggie ) ) : ( $storage->load(@id{qw(Lisa Maggie)}) ), ) ); $storage->update($homer); @id{qw(Lisa Maggie)} = $storage->id($lisa, $maggie); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->reset(); undef $homer; Springfield::leaktest; $storage->disconnect; } { my $storage = Springfield::connect; my @prefetch = $storage->prefetch( 'NaturalPerson', $children ); my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $bart = $storage->load( $id{Bart} ); Springfield::test( !$intrusive || $bart->{is_parent}{firstName} eq 'Homer' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $person = $storage->remote('NaturalPerson'); my @prefetch = $storage->prefetch( $person, $children, $person->{firstName} eq 'Homer' ); my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; ######### # queries my $parents = $intrusive ? 'Homer' : 'Homer Marge'; { my $storage = Springfield::connect; my ($parent, $child) = $storage->remote(qw( NaturalPerson NaturalPerson )); #local $Opal::TRACE = \*STDOUT; my @results = $storage->select( $parent, $parent->{$children}->includes( $child ) & $child->{firstName} eq 'Bart' ); Springfield::test( join( ' ', sort map { $_->{firstName} } @results ) eq $parents ); marge_test( $storage ); $storage->disconnect(); } Springfield::leaktest; { #local($Tangram::TRACE) = \*STDERR; my $storage = Springfield::connect; my $parent = $storage->remote( 'NaturalPerson' ); my $lisa = $storage->load( $id{Lisa} ); my @results = $storage->select ( $parent, $parent->{$children}->includes( $lisa ) ); #print "# `", join( ' ', sort map { $_->{firstName} } @results ),"' vs `", $parents,"'\n"; Springfield::test( join( ' ', sort map { $_->{firstName} } @results ) eq $parents ); $storage->disconnect(); } Springfield::leaktest; { my $storage = Springfield::connect_empty; my @children = map { NaturalPerson->new( firstName => $_ ) } @kids; my $homer = NaturalPerson->new( firstName => 'Homer', $children => Set::Object->new( @children ) ); my $abe = NaturalPerson->new( firstName => 'Abe', $children => Set::Object->new( $homer ) ); $id{Abe} = $storage->insert($abe); $storage->disconnect(); } Springfield::leaktest; { my $storage = Springfield::connect; $storage->erase( $storage->load( $id{Abe} ) ); my @pop = $storage->select('NaturalPerson'); Springfield::test( @pop == 0 ); $storage->disconnect(); } Springfield::leaktest; ############################################################################# # Tx Springfield::tx_tests(8, sub { stdpop(); # check rollback of DB tx Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); $storage->tx_start(); $homer->{$children}->remove( $storage->load( $id{Bart} ) ); $storage->update( $homer ); $storage->tx_rollback(); $storage->disconnect; } Springfield::leaktest; # storage should still contain 3 children { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; # check that DB and collection state remain in synch in case of rollback { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); $storage->tx_start(); $homer->{$children}->remove( $storage->load( $id{Bart} ) ); $storage->update( $homer ); $storage->tx_rollback(); $storage->update( $homer ); $storage->disconnect; } # Bart should no longer be Homer's child { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; } ); # tx_tests 1; Tangram-2.12/t/springfield/03-queries.t0000644000175000017500000001502412605617704016372 0ustar samvsamv# -*- perl -*- # Portions Copyright (c) 2002-2004, Sam Vilain. All rights reserved. # This program is free software; you may use it and/or modify it under # the same terms as Perl itself. use strict; use lib "t/springfield"; use Springfield; # $Tangram::TRACE = \*STDOUT; use Test::More tests => 24; #-------------------- # setup tests { my $storage = Springfield::connect_empty; my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson' ); my $marge = NaturalPerson->new( firstName => 'Marge', name => 'Simpson' ); $marge->{partner} = $homer; $homer->{partner} = $marge; $storage->insert( $homer ); $storage->insert( NaturalPerson->new( firstName => 'Montgomery', name => 'Burns' ) ); delete $homer->{partner}; $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # filter on string field { my $storage = Springfield::connect; my ($person) = $storage->remote(qw( NaturalPerson )); my @results = $storage->select ( $person, $person->{name} eq 'Simpson' ); is(join( ' ', sort map { $_->{firstName} } @results ), 'Homer Marge', "filter on string field"); $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # logical and { my $storage = Springfield::connect; my ($person) = $storage->remote(qw( NaturalPerson )); my @results = $storage->select ( $person, ($person->{firstName} eq 'Homer') & ($person->{name} eq 'Simpson' ) ); is( @results, 1, "Logical and"); is ( $results[0]{firstName}, 'Homer', "Logical and" ); $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # join on a ref link { my $storage = Springfield::connect; my ($person, $partner) = $storage->remote(qw( NaturalPerson NaturalPerson )); my @results = $storage->select ( $person, ($person->{partner} == $partner) & ($partner->{firstName} eq 'Marge') ); is( @results, 1, "Logical and"); is ( $results[0]{firstName}, 'Homer', "Logical and" ); $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # two birds with one stone; test that Tangram doesn't go disconnecting # DBI handles that it was passed! my $dbh = DBI->connect($cs, $user, $passwd) or die "DBI->connect failed; $DBI::errstr"; #-------------------- # now, test IS NOT NULL query { my $storage = Springfield::connect(undef, { dbh => $dbh }); my ($person) = $storage->remote(qw( NaturalPerson )); my @results = $storage->select( $person, $person->{partner} != undef ); is(join( ' ', sort map { $_->{firstName} } @results ), 'Homer Marge', "!= undef test"); $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # test outer joins; only really make sense with retrieve SKIP:{ skip "SQLite can't do nested joins", 2 if DBConfig->dialect =~ /sqlite/i; skip "MySQL known to return incorrect results for nested joins", 2 if DBConfig->dialect =~ /mysql/i; # first, setup some test data { my $storage = Springfield::connect(undef, { dbh => $dbh }); my @people = $storage->select("NaturalPerson"); $storage->insert (LegalPerson->new(name => "Springfield Nuclear Power Plant", colour => "Fluourescant Green", )); for ( @people ) { $_->{colour} = "Yellow"; } $storage->update(@people); } { my $storage = Springfield::connect(undef, { dbh => $dbh }); #local($Tangram::TRACE) = \*STDERR; my ($person, $partner) = $storage->remote(qw( NaturalPerson NaturalPerson )); # FIXME - polymorphic outer joins don't work. This query # might actually return wrong results. A rethink is required. my $test_it = sub { my $cursor = $storage->cursor ( $person, @_ ); my @results; while ( my $person = $cursor->current ) { push @results, ($person->{firstName}.":" .join(":",map { $_||""} $cursor->residue)); $cursor->next(); } #diag(Data::Dumper::Dumper(\@results)); is_deeply(\@results, [ qw( Homer:Marge:Yellow Marge:: Montgomery:: ) ], "outer join"); }; $test_it->( retrieve => [ $partner->{firstName}, $partner->{colour}, ], order => [ $person->{firstName} ], outer_filter => ( ($person->{partner} == $partner) & ($partner->{firstName} == "Marge") ), ); #$Tangram::Global = 1; $test_it->( retrieve => [ $partner->{firstName}, $partner->{colour}, ], filter => ($person->{partner} == $partner), order => [ $person->{firstName} ], outer_filter => ($partner->{firstName} == "Marge"), force_outer => $partner ); $storage->disconnect(); } } is(&leaked, 0, "leaktest"); # here is the test for Tangram not disconnecting - this should work. eval { my $sth = $dbh->prepare("select count(*) from Tangram") or die $DBI::errstr; $sth->execute(); my @res = $sth->fetchall_arrayref; }; ok(!$DBI::err, "Disconnect didn't disconnect a supplied DBI handle"); #-------------------- # BEGIN ks.perl@kurtstephens.com 2002/10/16 # Test non-commutative operator argument swapping { my $storage = Springfield::connect; my ($person) = $storage->remote(qw( NaturalPerson )); # local $Tangram::TRACE = \*STDERR; my @results = $storage->select ( $person, ( 1 <= $person->{person_id} ) & ( $person->{person_id} <= 2 ) ); is(@results, 2, "non-commutative operator argument swapping" ); $storage->disconnect(); } is(&leaked, 0, "leaktest"); # END ks.perl@kurtstephens.com 2002/10/16 # test selecting some columns with no filter or object { my $storage = Springfield::connect; my ($person) = $storage->remote(qw( NaturalPerson )); #local $Tangram::TRACE = \*STDERR; my @results = $storage->select ( undef, retrieve => [ $person->{id} ], order => [ $person->{id} ], ); is(@results, 3, "no filter or object (get all IDs)" ); # now try to load them - this does really kooky stuff with # polymorphic selects (seemingly makes one select per subclass) my @objects = $storage->select ( $person, $person->{id}->in(@results), ); is(@objects, 3, "selected results"); isa_ok($_, "Person", "selected item") foreach (@objects); # test that class_id works for classes not in schema (an empty # subclass test) @UndeadPerson::ISA = qw(NaturalPerson); is($storage->class_id("UndeadPerson"), $storage->class_id("NaturalPerson"), "Storage can handle Undead objects"); $storage->disconnect(); } is(&leaked, 0, "leaktest"); $dbh->disconnect(); Tangram-2.12/t/springfield/81-poly.t0000644000175000017500000000235512605613635015710 0ustar samvsamv# -*- perl -*- # # # Portions (c) Sam Vilain, 2003 use strict; use Test::More tests => 8; use lib "t/springfield"; use Springfield; # $Tangram::TRACE = \*STDOUT; my $beer; { my $storage = Springfield::connect_empty; my @oids = $storage->insert ( NaturalPerson->new( firstName => 'Homer', name => 'Simpson' ), NaturalPerson->new( firstName => 'Marge', name => 'Simpson' ), LegalPerson->new( name => 'Kwik Market' ), LegalPerson->new( name => 'Springfield Nuclear Power Plant' ), Opinion->new(statement => "beer is good"), ); $beer = pop @oids; $storage->disconnect; } is(leaked, 0, "Nothing leaked yet!"); { my $storage = Springfield::connect; my @res; my $results = join( ', ', sort map { $_->as_string } (@res = $storage->select('Person')) ); #print "$results\n"; is($results, 'Homer Simpson, Kwik Market, Marge Simpson, Springfield Nuclear Power Plant', "Polymorphic retrieval via Tangram::Storage->select()" ); ok($storage->oid_isa($storage->id(shift(@res)), "Person"), "oid_isa(positive)") while @res; ok(!$storage->oid_isa($beer, "Person"), "oid_isa(negative)"); $storage->disconnect; } is(leaked, 0, "Nothing leaked yet!"); Tangram-2.12/t/springfield/70-mysql.t0000644000175000017500000000070312605613635016063 0ustar samvsamv use lib "t/springfield"; use Springfield; tests_for_dialect('mysql'); begin_tests(1); { my $storage = Springfield::connect_empty(); $storage->insert( NaturalPerson->new( firstName => 'Homer', age => 37 ), NaturalPerson->new( firstName => 'Marge', age => 34 ) ); my $p = $storage->remote('NaturalPerson'); my @results = $storage->select($p, $p->{age}->bitwise_and(1)); test @results == 1 && $results[0]{firstName} eq 'Homer'; } Tangram-2.12/t/springfield/30-ref.t0000644000175000017500000000363312605613635015473 0ustar samvsamv use lib "t/springfield"; use Springfield; my %id; Springfield::begin_tests(11); { $storage = Springfield::connect_empty; my $homer = NaturalPerson->new( firstName => 'Homer' ); my $marge = NaturalPerson->new( firstName => 'Marge' ); $homer->{partner} = $marge; $id{Marge} = $storage->insert($marge); $id{Homer} = $storage->insert($homer); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect(); my ($p1, $p2) = $storage->remote(qw( NaturalPerson NaturalPerson )); my ($homer, $other) = $storage->select( $p1, ($p1->{partner} == $p2) & ($p2->{firstName} eq 'Marge') ); Springfield::test( $homer && !$other ); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect(); my $marge = $storage->load( $id{Marge} ); my ($p1) = $storage->remote(qw( NaturalPerson )); my ($marge2, $other) = $storage->select( $p1, $p1 == $marge ); Springfield::test( $marge2 && !$other ); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect(); my $marge = $storage->load( $id{Marge} ); my ($p1, $p2) = $storage->remote(qw( NaturalPerson NaturalPerson )); my $ff = $p1 == $p1; my ($homer, $other) = $storage->select( $p1, $p1->{partner} == $marge ); Springfield::test( $homer && !$other ); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect_empty(); $ids{Homer} = $storage->insert( NaturalPerson->new( name => 'Homer', credit => Credit->new( limit => 1000 ) ) ); my @credits = $storage->select('Credit'); Springfield::test( @credits == 1 ); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect(); my $homer = $storage->load( $ids{Homer} ); print $homer->{credit}, "\n"; $storage->erase( $homer ); my @credits = $storage->select('Credit'); Springfield::test( @credits == 0 ); $storage->disconnect(); } Springfield::leaktest; Tangram-2.12/t/springfield/36-ihash.t0000644000175000017500000000015312605613635016013 0ustar samvsamv #$Tangram::TRACE=\*STDERR; use vars qw( $intrusive ); $intrusive = 1; require 't/springfield/35-hash.t'; Tangram-2.12/t/springfield/05-unload.t0000644000175000017500000000130412605613635016174 0ustar samvsamv use strict; use lib 't/springfield'; use Springfield; # $Tangram::TRACE = \*STDOUT; Springfield::begin_tests(3); { my $storage = Springfield::connect_empty; $storage->insert( NaturalPerson->new( firstName => 'Homer' )); $storage->unload(); Springfield::leaktest; $storage->disconnect(); } { my $storage = Springfield::connect_empty; $storage->insert( my $homer = NaturalPerson->new( firstName => 'Homer' )); my $marge_id = $storage->insert( my $marge = NaturalPerson->new( firstName => 'Marge' )); $storage->unload($homer); undef $homer; Springfield::test($SpringfieldObject::pop == 1); $storage->unload($marge_id); undef $marge; Springfield::leaktest; $storage->disconnect(); } Tangram-2.12/t/springfield/20-perldump.t0000644000175000017500000000120512605613635016537 0ustar samvsamv use lib "t/springfield"; use Springfield; begin_tests(1); my $id; { my $storage = Springfield::connect_empty(); $id = $storage ->insert( NaturalPerson->new( firstName => 'Homer', brains => { likes => [ qw( beer food ) ], dislikes => [ qw( Flanders taxes ) ], } ) ); $storage->disconnect(); } { my $storage = Springfield::connect(); my $homer = $storage->load($id); test( join('|', sort keys %{ $homer->{brains} }) eq 'dislikes|likes' && "@{ $homer->{brains}{likes} }" eq 'beer food' && "@{ $homer->{brains}{dislikes} }" eq 'Flanders taxes' ); $storage->disconnect(); } Tangram-2.12/t/springfield/37-prefetch.t0000644000175000017500000000724512605613635016531 0ustar samvsamv#!/usr/bin/perl -ws use strict; # command line parameters - see perlrun (-s switch) use vars qw($debug); use Test::More tests => 110; use lib "t/springfield"; use Springfield qw(%id stdpop leaked @kids @opinions); my $tests = {( "IntrArray" => [ 1, "ia_children", "NaturalPerson", ], "Array" => [ 0, "children", "NaturalPerson", ], "Hash" => [ 0, "h_opinions", "Opinion", ], "IntrHash" => [ 1, "ih_opinions", "Opinion", ], "Set" => [ 0, "s_children", "NaturalPerson", ], "IntrSet" => [ 1, "is_children", "NaturalPerson", ], "DiffIntrArray" => [ 1, "ia_opinions", "Opinion", ], "DiffArray" => [ 0, "a_opinions", "Opinion", ], "DiffIntrSet" => [ 1, "is_opinions", "Opinion", ], "DiffSet" => [ 0, "s_opinions", "Opinion", ], )}; while (my ($test_name, $data) = each %$tests) { my ($intrusive, $children, $class) = @{ $data }; #diag("Running test $test_name"); test_prefetch($test_name, $intrusive, $children, $class); } sub test_prefetch { my ($test_name, $intrusive, $children, $class) = (@_); stdpop($children); for my $do_prefetch (0..1) { # Check that the test is valid: { my $storage = Springfield::connect; #local($Tangram::TRACE) = \*STDOUT; my $Homer = $storage->load( $id{Homer} ); my ($r_parent, $r_child) = $storage->remote( "NaturalPerson", $class ); my $filter = ($r_parent == $Homer); my $filter2 = ($filter & $r_parent->{$children}->includes($r_child) ); my @parents = $storage->select( $r_parent, $filter2 ); my @children = $storage->select( $r_child, $filter2 ); my @k = ($children =~ m/children/ ? @kids : @opinions); @children = sort { my $ix_a; my $ix_b; my $count = 0; for (@k) { $ix_a = $count if ( (exists $a->{firstName} && $a->{firstName} eq $_) || (exists $a->{statement} && $a->{statement} eq $_) ); $ix_b = $count if ( (exists $b->{firstName} && $b->{firstName} eq $_) || (exists $b->{statement} && $b->{statement} eq $_) ); $count++; } $ix_a <=> $ix_b; } @children if ($children =~ /children|a_/); ok(@children, "$test_name - Got some children back"); { #local($Tangram::TRACE); #if ($test_name =~ /IntrArray/) { #$Tangram::TRACE = \*STDERR; #} $storage->prefetch( $r_parent, $children, $filter ) if $do_prefetch; } $storage->{db}->disconnect(); # hyuk yuk yuk local($SIG{__WARN__}) = sub { }; my @new_children; my $sort = sub { (exists $a->{firstName} ? ( $a->{firstName} cmp $b->{firstName} ) : ( $a->{statement} cmp $b->{statement} ) ); }; eval { if ($children =~ m/s_/) { @new_children = sort { $sort->() } $Homer->{$children}->members; @children = sort { $sort->() } @children; } elsif ($children =~ m/children|a_/) { @new_children = @{ $Homer->{$children} }; } else { @new_children = sort { $sort->() } values %{ $Homer->{$children} }; @children = sort { $sort->() } @children; } }; if ($do_prefetch) { is($@, "", "$test_name - Didn't raise an exception w/prefetch"); #local ($,)=" "; #print map { ref $_ ? $_->{firstName} : $_ } #"Sent:", @children, #"\nGot: ", @new_children, "\n"; is_deeply(\@new_children, \@children, "$test_name - got back what we put in"); } else { isnt($@, "", "$test_name - Raises an exception w/o prefetch"); isnt(@new_children, @children, "$test_name - didn't get back what we put in"); } $storage->disconnect(); } is(leaked, 0, "Leaktest"); } } $a = $b = "globals"; Tangram-2.12/t/springfield/82-aggregate.t0000644000175000017500000000455112605613635016654 0ustar samvsamv#!/usr/bin/perl -w use strict; use lib "t/springfield"; use Springfield; use Test::More tests => 10; =head1 NAME t/aggregate.t - test aggregate tangram functions =head1 SYNOPSIS perl -Mlib=lib t/springfield/00-deploy.t perl -Mlib=lib t/springfield/aggregate.t =head1 DESCRIPTION This test script tests using Tangram for aggregate functionality, such as when no object is selected. =cut stdpop(); my $dbh = DBI->connect($cs, $user, $passwd) or die "DBI->connect failed; $DBI::errstr"; # test GROUP BY and COUNT { my $storage = Springfield::connect(undef, { dbh => $dbh }); my ($r_person, $r_child) = $storage->remote(("NaturalPerson")x2); #local($Tangram::TRACE)=\*STDERR; my $cursor = $storage->cursor ( undef, filter => $r_person->{children}->includes($r_child), group => [ $r_person ], retrieve => [ $r_child->count(), $r_child->{age}->sum() ], #order => [ $r_child->{id}->count() ], ); my @data; while ( my $row = $cursor->current() ) { push @data, [ $cursor->residue ]; $cursor->next(); } @data = sort { $a->[0] <=> $b->[0] } @data; #print Data::Dumper::Dumper(\@data); is_deeply(\@data, [ [ 1, 38 ], [3, 19 ], [3, 19] ], "GROUP BY, SUM(), COUNT()"); } is(&leaked, 0, "leaktest"); # test GROUP BY and COUNT { my $storage = Springfield::connect(undef, { dbh => $dbh }); my ($r_legal) = $storage->remote("LegalPerson"); my $count = $storage->count($r_legal); my $expected = 0; if ( $count == 1 ) { $expected = 1; } is($count, $expected, "Tangram::Storage->count(Subclass)"); $storage->insert(LegalPerson->new(name => "Springfield Nuclear Plant")) unless $storage->count($r_legal); #local($Tangram::TRACE)=\*STDERR; my $cursor = $storage->cursor ( undef, retrieve => [ $r_legal->count() ], ); my @data; while ( my $row = $cursor->current() ) { push @data, [ $cursor->residue ]; $cursor->next(); } #print Data::Dumper::Dumper(\@data); is_deeply(\@data, [ [ 1 ] ], "->COUNT() filters types"); } is(&leaked, 0, "leaktest"); # test $storage->sum() - single, array ref, set arguments { my $storage = Springfield::connect(undef, { dbh => $dbh}); my ($r_person) = $storage->remote("NaturalPerson"); is($storage->sum($r_person->{age}), 156, "Tangram::Storage->sum()"); is(&leaked, 0, "leaktest"); } Tangram-2.12/t/springfield/32-iset.t0000644000175000017500000000011712605613635015657 0ustar samvsamv use vars qw( $intrusive ); $intrusive = 1; require 't/springfield/31-set.t'; Tangram-2.12/t/springfield/33-array.t0000644000175000017500000002464012605613635016041 0ustar samvsamv# -*- perl -*- use strict; # for emacs debugger #use lib "../blib/lib"; #use lib "."; use lib "t/springfield"; use Springfield qw(stdpop %id leaked @kids); # This is set to 1 by iarray.t use vars qw( $intrusive ); BEGIN { my $tests = ($intrusive ? 49 : 57); eval "use Test::More tests => $tests;"; die $@ if $@; } #$intrusive = 1; #$Tangram::TRACE = \*STDOUT; my $children = $intrusive ? 'ia_children' : 'children'; sub NaturalPerson::children { my ($self) = @_; join(' ', map { $_->{firstName} || '' } @{ $self->{$children} } ) } sub marge_test { my $storage = shift; SKIP: unless ($intrusive) { #skip("n/a to Intrusive Tests", 1) if $intrusive; is( $storage->load( $id{Marge} )->children, 'Bart Lisa Maggie', "Marge's children all found" ); } } #===================================================================== # TESTING BEGINS #===================================================================== # insert the test data stdpop($children); is(leaked, 0, "Nothing leaked yet!"); # Test that updates notice changes to collections { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); ok($homer, "Homer still exists!"); is($homer->children, 'Bart Lisa Maggie', "array auto-vivify 1" ); marge_test( $storage ); @{ $homer->{$children} }[0, 2] = @{ $homer->{$children} }[2, 0]; $storage->update( $homer ); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is($homer->children, 'Maggie Lisa Bart', "array update test 1"); marge_test( $storage ); pop @{ $homer->{$children} }; $storage->update( $homer ); $storage->disconnect; } ############################################### # insert { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; is( $homer->children, 'Maggie Lisa', "array update test 2 (pop)" ); shift @{ $homer->{$children} }; $storage->update($homer); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; is( $homer->children, 'Lisa', "array update test 2 (shift)" ); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; shift @{ $homer->{$children} }; $storage->update($homer); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; is( $homer->children, "", "array update test 3 (all gone)"); push @{ $homer->{$children} }, $storage->load( $id{Bart} ); $storage->update($homer); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; is( $homer->children, 'Bart', "array insert test 1" ); push ( @{ $homer->{$children} }, $storage->load( @id{qw(Lisa Maggie)} ) ); $storage->update($homer); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "array insert test 2" ); marge_test( $storage ); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "still there" ); marge_test( $storage ); $storage->unload(); undef $homer; is(leaked, 0, "leaktest (unload)"); $storage->disconnect; } ########### # back-refs SKIP: if ($intrusive) { skip("Intr types test only", 2) unless $intrusive; my $storage = Springfield::connect; my $bart = $storage->load( $id{Bart} ); is($bart->{ia_parent}{firstName}, 'Homer', "array back-refs" ); marge_test( $storage ); $storage->disconnect; } is(leaked, 0, "leaktest"); ########## # prefetch # FIXME - add documentation to Tangram::Storage for prefetch { my $storage = Springfield::connect; my @prefetch = $storage->prefetch( 'NaturalPerson', $children ); my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "prefetch test returned same results"); marge_test( $storage ); $storage->disconnect(); } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $person = $storage->remote('NaturalPerson'); my @prefetch = $storage->prefetch( 'NaturalPerson', $children ); my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "prefetch test returned same results"); marge_test( $storage ); $storage->disconnect(); } is(leaked, 0, "leaktest"); ######### # queries my $parents = $intrusive ? 'Homer' : 'Homer Marge'; my $pops = $intrusive ? 'Abraham Homer' : 'Abraham Homer Marge'; { my $storage = Springfield::connect; my ($parent, $child) = $storage->remote(qw( NaturalPerson NaturalPerson )); ##local($Tangram::TRACE) = \*STDERR; my @results = $storage->select ( $parent, $parent->{$children}->includes( $child ) & $child->{firstName} eq 'Bart' ); is(join( ' ', sort map { $_->{firstName} } @results ), $parents, "Query (array->includes(t2) & t2->{foo} eq Bar)" ); $storage->disconnect(); } is(leaked, 0, "leaktest"); SKIP: { skip "SQLite doesn't like IN having a non hard-coded list", 1 if DBConfig->dialect =~ /sqlite/i; my $storage = Springfield::connect; my ($parent, $child1, $child2) = $storage->remote(qw( NaturalPerson NaturalPerson NaturalPerson )); #local($Tangram::TRACE) = \*STDERR; my @results = $storage->select ( $parent, $parent->{$children}->includes_or( $child1, $child2 ) # note the caveat - both these conditions must hold for one # row, although this may not be the one selected; ie, if I # replace "Homer" with "Montgomery", I get *NO* results - # RDBMSes suck :-) & $child1->{firstName} eq 'Bart' & $child2->{firstName} eq 'Homer' ); is(join( ' ', sort map { $_->{firstName} } @results ), $pops, "Query (includes_or with two remotes)" ); $storage->disconnect(); } is(leaked, 0, "leaktest"); #diag("-"x69); { my $storage = Springfield::connect; my ($parent, $child) = $storage->remote(qw( NaturalPerson NaturalPerson )); my @males = $storage->select ( $child, $child->{firstName} eq 'Bart' | $child->{firstName} eq 'Homer' ); #local($Tangram::TRACE) = \*STDERR; my @results = $storage->select ( $parent, $parent->{$children}->includes_or( @males ) ); is(join( ' ', sort map { $_->{firstName} } @results ), $pops, "Query (includes_or with two objects)" ); $storage->disconnect(); } is(leaked, 0, "leaktest"); #diag("-"x69); SKIP:{ skip "SQLite doesn't like IN having a non hard-coded list", 1 if DBConfig->dialect =~ /sqlite/i; skip "Oracle doesn't like DISTINCT on CLOBs; we need a new test suite ;)", 1 if DBConfig->dialect =~ /oracle/i; my $storage = Springfield::connect; my ($parent, $child ) = $storage->remote(qw( NaturalPerson NaturalPerson )); my @male = $storage->select ( $parent, $parent->{firstName} eq 'Bart' ); #local($Tangram::TRACE) = \*STDERR; my @results = $storage->select ( $parent, filter => ($parent->{$children}->includes_or( @male, $child ) & ($child->{firstName} eq "Homer")), distinct => 1, ); is(join( ' ', sort map { $_->{firstName} } @results ), $pops, "Query (includes_or with one objects & one remote)" ); $storage->disconnect(); } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $parent = $storage->remote( 'NaturalPerson' ); my $bart = $storage->load( $id{Bart} ); my @results = $storage->select ( $parent, $parent->{$children}->includes( $bart ) ); is(join( ' ', sort map { $_->{firstName} } @results ), $parents, 'Query (array->includes($dbobj))' ); $storage->disconnect(); } is(leaked, 0, "leaktest"); ############# # aggreg => 1 { my $storage = Springfield::connect_empty; my @children = (map { NaturalPerson->new( firstName => $_ ) } @kids); my $homer = NaturalPerson->new ( firstName => 'Homer', $children => [ map { NaturalPerson->new( firstName => $_ ) } @kids ] ); my $abe = NaturalPerson->new( firstName => 'Abe', $children => [ $homer ] ); $id{Abe} = $storage->insert($abe); $storage->disconnect(); } is(leaked, 0, "leaktest"); SKIP: { my $storage = Springfield::connect; $storage->erase( $storage->load( $id{Abe} ) ); my @pop = $storage->select('NaturalPerson'); is(@pop, 0, "aggreg deletes children via arrays"); #skip( "n/a to Intrusive Tests", 1 ) if $intrusive; unless ($intrusive) { is($storage->connection()->selectall_arrayref ("SELECT COUNT(*) FROM a_children")->[0][0], 0, "Link table cleared successfully after remove"); } $storage->disconnect(); } is(leaked, 0, "leaktest"); ############################################################################# # Tx SKIP: { skip "No transactions configured/supported", ($intrusive ? 9 : 11) if $Springfield::no_tx; stdpop($children); # check rollback of DB tx is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); $storage->tx_start(); shift @{ $homer->{$children} }; $storage->update( $homer ); $storage->tx_rollback(); $storage->disconnect; } is(leaked, 0, "leaktest"); # storage should still contain 3 children { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "rollback 1" ); marge_test( $storage ); $storage->disconnect; } is(leaked, 0, "leaktest"); # check that DB and collection state remain in synch in case of rollback { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); $storage->tx_start(); shift @{ $homer->{$children} }; $storage->update( $homer ); $storage->tx_rollback(); $storage->update( $homer ); $storage->disconnect; } # Bart should no longer be Homer's child { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Lisa Maggie', "auto-commit on disconnect" ); marge_test( $storage ); $storage->disconnect; } is(leaked, 0, "leaktest"); } 1; Tangram-2.12/t/springfield/01-mappings.t0000644000175000017500000000750412605613635016534 0ustar samvsamv# -*- cperl-mode -*- use strict; use lib 't/springfield'; use Springfield; use Test::More tests => 70; package Vehicle; sub new { my $self = bless { }, shift; } sub make { my $class = shift; my $self = bless { }, $class; @$self{ $self->fields } = @_; return $self; } sub state { my $self = shift; join ' ', ref($self), @$self{ $self->fields }; } package Boat; use base qw( Vehicle ); sub fields { qw( name knots ) } package Plane; use base qw( Vehicle ); sub fields { qw( name altitude ) } package HydroPlane; use base qw( Boat Plane ); sub fields { qw( name knots altitude whatever ) } package main; sub check { my ($storage, $test_name, $class, @states) = @_; my @objs; eval { @objs = $storage->select($class); }; is($@, "", "$test_name: selecting $class objects doesn't die"); is(@objs, @states, "$test_name: correct # of $class objects"); if (@objs == @states) { my %states; @states{ @states } = (); delete @states{ map { $_->state } @objs }; is(keys %states, 0, "$test_name: objects correspond exactly"); } else { SKIP:{ skip("$test_name: carried error", 1); } } } sub test_mapping { my ($v, $b, $p, $h) = @_; my $test_name = "$v$b$p$h"; my $schema = Tangram::Relational->schema ( { control => 'Vehicles', classes => [ Vehicle => { table => $v, abstract => 1, fields => { string => [ 'name' ] } }, Boat => { table => $b, bases => [ qw( Vehicle ) ], fields => { int => [ 'knots' ] }, }, Plane => { table => $p, bases => [ qw( Vehicle ) ], fields => { int => [ 'altitude' ] }, }, HydroPlane => { table => $h, bases => [ qw( Boat Plane ) ], fields => { string => [ 'whatever' ] }, }, ] } ); use YAML; #diag(Dump $schema); SKIP: { my $dbh = DBI->connect($Springfield::cs, $Springfield::user, $Springfield::passwd, { PrintError => 0 }); # $Tangram::TRACE = \*STDOUT; eval { $Springfield::dialect->retreat($schema, $dbh) }; eval { $Springfield::dialect->deploy($schema, $dbh); }; is($@, "", "$test_name: deploy succeeded") or skip "$test_name: deploy failed", 13; $dbh->disconnect(); my $storage = Springfield::connect($schema); # use Data::Dumper; print Dumper $storage->{engine}->get_polymorphic_select($schema->classdef('Boat')); die; # my $t = HydroPlane->make(qw(Hydro 5 200 foo)); print Dumper $t; die; eval { $storage->insert( Boat->make(qw( Erika 2 )), Plane->make(qw( AF-1 20000 )), HydroPlane->make(qw(Hydro 5 200 foo)) ); }; is($@, "", "$test_name: Inserting objects doesn't die"); check($storage, $test_name, 'Boat', 'Boat Erika 2', 'HydroPlane Hydro 5 200 foo'); check($storage, $test_name, 'Plane', 'Plane AF-1 20000', 'HydroPlane Hydro 5 200 foo'); check($storage, $test_name, 'HydroPlane', 'HydroPlane Hydro 5 200 foo'); check($storage, $test_name, 'Vehicle', 'Boat Erika 2', 'Plane AF-1 20000', 'HydroPlane Hydro 5 200 foo'); $storage->disconnect(); } } test_mapping('V', 'V', 'V', 'V'); test_mapping('V', 'V', 'V', 'H'); test_mapping('V', 'B', 'V', 'V'); test_mapping('V', 'V', 'P', 'V'); test_mapping('V', 'B', 'P', 'V'); __END__ { my $schema = $dialect ->schema( { control => 'Mappings', classes => [ Fruit => { abstract => 1 }, Apple => { bases => [ 'Fruit' ] }, AppleTree => { fields => { iset => { fruits => 'Apple' } } } ] } ); $Tangram::TRACE = \*STDOUT; $dialect->retreat($schema, $cs, $user, $passwd, { PrintError => 0 }); $dialect->deploy($schema, $cs, $user, $passwd, { PrintError => 0 }); my $storage = $dialect->connect($schema, $cs, $user, $passwd); $storage->insert( bless { fruits => Set::Object->new( bless { }, 'Apple' ) }, 'AppleTree' ); $storage->disconnect(); } Tangram-2.12/t/springfield/21-flatarray.t0000644000175000017500000001035512605613635016703 0ustar samvsamv# -*- perl -*- ergo sum use strict; use lib 't/springfield'; use Springfield; use Test::More tests => 24; { my $storage = Springfield::connect_empty(); my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', interests => [ qw( beer food ) ] ); $storage->insert($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", 'beer food', "Flat array store/retrieve"); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); push @{ $homer->{interests} }, 'sex'; $storage->update($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", 'beer food sex', "Array change flushed successfully"); pop @{ $homer->{interests} }; $storage->update($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", 'beer food', "Array change flushed again successfully"); unshift @{ $homer->{interests} }, 'sex'; $storage->update($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", 'sex beer food', "Array change flushed yet again successfully"); delete $homer->{interests}; $storage->update($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", '', "Removing array flushes from DB"); $homer->{interests} = [ qw( beer food ) ]; $storage->update($homer); $storage->insert( NaturalPerson->new( firstName => 'Marge', name => 'Simpson', interests => [ qw( kids household cooking cleaning ) ] ) ); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); # exists, includes { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); my @results = $storage->select($remote, $remote->{interests}->includes('beer')); is(@results, 1, "Got back one result only"); is($results[0]->{firstName}, 'Homer', "Select by array entry"); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { SKIP: { my $storage = Springfield::connect(); $storage->disconnect, skip "Sub-select tests disabled", 2, if $storage->{no_subselects}; my ($remote) = $storage->remote('NaturalPerson'); my @results = $storage->select($remote, $remote->{interests}->exists('beer')); is(@results, 1, "I'll wash all the dishes,"); is($results[0]->{firstName}, 'Homer', "And you go have a beer"); $storage->disconnect(); } } is(leaked, 0, "Nothing leaked"); # prefetch { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); $storage->prefetch($remote, 'interests'); my ($homer) = $storage->select($remote, $remote->{firstName} eq 'Homer'); { local ($storage->{db}); is("@{ $homer->{interests} }", 'beer food', "Prefetch test - no prefetch filter"); } $storage->disconnect(); } is(leaked, 0, "Nothing leaked - here 1"); { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); $storage->prefetch($remote, 'interests', $remote->{firstName} eq 'Homer'); my ($homer) = $storage->select($remote, $remote->{firstName} eq 'Homer'); { local ($storage->{db}); is("@{ $homer->{interests} }", 'beer food', "Another prefetch test - prefetch filter" ); } $storage->disconnect(); } THEEND: is(leaked, 0, "Nothing leaked - here 2"); { my $storage = Springfield::connect(); $storage->erase( $storage->select('NaturalPerson')); $storage->disconnect(); $storage = Springfield::connect(); is( $storage->connection()->selectall_arrayref("SELECT COUNT(*) FROM NaturalPerson_interests")->[0][0], 0, "All interests cleaned up correctly" ); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); Tangram-2.12/t/springfield/42-idbif.t0000644000175000017500000000446412605613635016002 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 32; use lib "t/springfield"; use Springfield; for my $fairy ("FaerieHairy", "Faerie") { #--------------------------------------------------------------------- # Test simple insertion of an explicitly listed field. { my $storage = Springfield::connect_empty(); my $bert = new $fairy( name => "Bert" ); my $bob = new $fairy( name => "Bob" ); $bert->{friends} = [ "Jesus" # everyone's friend ]; $bob->{friends} = { first => "Buddha" }; $bob->{foo} = "bar"; $storage->insert($bert, $bob); ok($storage->id($bert), "Bert got an ID ($fairy)"); ok($storage->id($bob), "Bob got an ID ($fairy)"); } is(leaked, 0, "leaktest"); # test update of an explicitly listed field, that contains a reference # to another object. { my $storage = Springfield::connect(); my $pixie = $storage->remote($fairy); my ($bert) = $storage->select($pixie, $pixie->{name} eq "Bert"); ok($bert, "Fetched Bert by name"); is($bert->{friends}->[0], "Jesus", "Jesus still Bert's friend"); my ($bob) = $storage->select($pixie, $pixie->{name} eq "Bob"); ok($bob, "Fetched Bob by name"); is($bob->{friends}->{first}, "Buddha", "The Buddha still on Bob's side"); is($bob->{foo}, (($fairy eq "Faerie") ? "bar" : undef), "Unknown attribute saved appropriately"); push @{ $bert->{friends} }, $bob; $bob->{friends}->{second} = $bert; #local($Tangram::TRACE)=\*STDERR; $storage->update($bert, $bob); delete $bert->{friends}; # break cyclic reference... } is(leaked, 0, "leaktest"); # test that the above worked. { my $storage = Springfield::connect(); my $pixie = $storage->remote($fairy); my ($bert) = $storage->select($pixie, $pixie->{name} eq "Bert"); ok($bert, "Fetched Bert by name"); ok($bert->{friends}->[1], "Bert has another friend now"); is($bert->{friends}->[1]->{name}, "Bob", "Bert's other friend is Bob"); my ($bob) = $storage->select($pixie, $pixie->{name} eq "Bob"); ok($bob, "Fetched Bob by name"); ok($bob->{friends}->{second}, "Bob's has another friend now"); is($bob->{friends}->{second}, $bert, "Bob's other friend is Bert"); $storage->update($bert, $bob); delete $bert->{friends}; # break cyclic reference... } is(leaked, 0, "leaktest"); } Tangram-2.12/t/springfield/Springfield.pm0000644000175000017500000002653712605613635017126 0ustar samvsamvuse 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; Tangram-2.12/t/springfield/34-iarray.t0000644000175000017500000000012112605613635016177 0ustar samvsamv use vars qw( $intrusive ); $intrusive = 1; require 't/springfield/33-array.t'; Tangram-2.12/t/springfield/04-tx.t0000644000175000017500000000126512605613635015352 0ustar samvsamv use strict; use lib 't/springfield'; use Springfield; Springfield::begin_tests(4); Springfield::connect_empty()->disconnect(); # init $no_tx Springfield::tx_tests(4, sub { { my $storage = Springfield::connect_empty; my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson' ); Springfield::test( !defined $storage->id( $homer ) ); eval { $storage->tx_do( sub { $storage->insert( $homer ); Springfield::test( defined $storage->id( $homer ) ); die; } ); }; Springfield::test( !defined $storage->id( $homer ) ); $storage->disconnect(); } Springfield::leaktest; } ); # tx_tests Tangram-2.12/t/springfield/06-reload.t0000644000175000017500000000144612605613635016170 0ustar samvsamv # I'm not sure exactly what aspect of `reload' this is testing... use strict; use lib 't/springfield'; use Springfield; # $Tangram::TRACE = \*STDOUT; Springfield::begin_tests(5); { my $storage = Springfield::connect_empty; $storage->insert( NaturalPerson->new( firstName => 'Marge', name => 'Bouvier' ) ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my ($marge) = $storage->select('NaturalPerson'); testcase($marge->{name} eq 'Bouvier'); $marge->{name} = 'Simpson'; $marge->{children} = [ NaturalPerson->new( firstName => 'Bart', name => 'Simpson' ) ]; $storage->update($marge); $storage->reload($marge); testcase($marge->{name} eq 'Simpson'); testcase(@{ $marge->{children} } == 1); $storage->disconnect; } Springfield::leaktest; 1; Tangram-2.12/t/springfield/15-datetime.t0000644000175000017500000000451612605613635016517 0ustar samvsamv#!/usr/bin/perl use strict; use lib 't/springfield'; use Springfield; BEGIN { eval "use Date::Manip qw(ParseDate);"; if ($@) { eval 'use Test::More skip_all => "Date::Manip not installed";'; } else { eval 'use Test::More tests => 11;'; } } my $do_rawtests = ($dialect =~ m/^Tangram::mysql$/); #tests_for_dialect(qw( mysql Pg )); #$Tangram::TRACE = \*STDOUT; my %ids; { my $storage = Springfield::connect_empty; my $jll = NaturalPerson->new ( firstName => 'Jean-Louis', ($do_rawtests ?( birthDate => '1963-8-13', birthTime => '11:34:17', birth => '1963-8-13 11:34:17', ) : ()), incarnation => ParseDate('1963-8-13 11:34:17'), ); $ids{jll} = $storage->insert($jll); my $chloe = NaturalPerson->new ( firstName => 'Chloe', ($do_rawtests ? (birth => '1993-7-28 13:10:00') : () ), incarnation => ParseDate('1993-7-28 13:10:00'), ); $ids{chloe} = $storage->insert($chloe); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $jll = $storage->load( $ids{jll} ); SKIP:{ skip "RAW date/time tests not worth it", 6 unless $do_rawtests; like($jll->{birthTime}, qr/11/, "raw time [1]"); like($jll->{birthTime}, qr/34/, "raw time [2]"); like($jll->{birthTime}, qr/17/, "raw time [3]"); like($jll->{birthDate}, qr/1963/, "raw date [1]"); like($jll->{birthDate}, qr/13/, "raw date [2]"); like($jll->{birthDate}, qr/8/, "raw date [3]"); } my $rp = $storage->remote(qw( NaturalPerson )); # FIXME - this is pretty much a hack for now. It doesn't seem # straightforward to overload Tangram::DMDateTime::binop to be # able to wrap the arg later on. This works for now! my @results = $storage->select ( $rp, $rp->{incarnation} > $storage->to_dbms('date', '1990-01-01T12:00:00') ); is(@results, 1, "Select by date compare"); is($storage->id( $results[0] ), $ids{chloe}, "got right object back" ); like( $results[0]->{incarnation}, qr/^\d{10}:\d\d:\d\d$/, "Dates returned in ISO8601 form" ); # if (optional_tests('epoch; no Time::Local', # eval { require 'Time::Local' }, 1)) { # Springfield::test($jll->{birthDate} =~ /1963/ # && $jll->{birthDate} =~ /13/ # && $jll->{birthDate} =~ /8/ # ); # } $storage->disconnect; } is(leaked, 0, "leaktest"); 1; Tangram-2.12/t/springfield/zz-retreat.t0000644000175000017500000000072112605613635016601 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 2; use lib "t/springfield"; BEGIN { use_ok "Springfield"; }; local $/; SKIP: { my $dbh = DBI->connect( $Springfield::cs, $Springfield::user, $Springfield::passwd ) or skip "could not connect to database", 1; $dbh->{RaiseError} = 1; $Springfield::dialect->retreat($Springfield::schema, $dbh); pass("retreat completed without raising errors"); $dbh->disconnect; } Tangram-2.12/t/springfield/00-deploy.t0000644000175000017500000000121212605613635016177 0ustar samvsamv#!/usr/bin/perl -w use strict; use lib "t"; use TestNeeds qw(Test::More Set::Object); use Test::More tests => 2; use lib "t/springfield"; BEGIN { use_ok "Springfield"; }; local $/; SKIP: { my $dbh = DBI->connect( $Springfield::cs, $Springfield::user, $Springfield::passwd ) or skip "could not connect to database", 1; do { local $dbh->{PrintError}; local $dbh->{RaiseError}; $Springfield::dialect->retreat($Springfield::schema, $dbh); }; $dbh->{RaiseError} = 1; $Springfield::dialect->deploy($Springfield::schema, $dbh); pass("deploy completed without raising errors"); $dbh->disconnect; } Tangram-2.12/t/springfield/40-dump.t0000644000175000017500000000775012605613635015671 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 20; use_ok("Tangram::Dump"); use Data::Dumper; use lib "t/springfield"; use Springfield; use Set::Object qw(is_overloaded blessed); use Tangram::Type::Dump qw(flatten unflatten); my $homer_id; { my $storage = Springfield::connect_empty(); my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', "ih_opinions" => { work => Opinion->new(statement => 'bad'), food => Opinion->new(statement => 'good'), beer => Opinion->new(statement => 'better') }, ); my $marge = NaturalPerson->new( firstName => 'Marge', name => 'Simpson' ); $homer->{partner} = $marge; $marge->{partner} = $homer; $homer_id = $storage->insert($homer); # now, make a data structure... my $structure = { hello => $homer, #foo => "bar", #baz => [ qw(frop quux), $homer ], #cheese => \\$marge, #bananas => Set::Object->new($homer, $marge), }; flatten($storage, $structure); is(ref $structure->{hello}, "Tangram::Memento", "blessed object removed - 1"); unflatten($storage, $structure); is($structure->{hello}, $homer, "unflatten - 1"); $structure = { hello => $homer, foo => "bar", baz => [ qw(frop quux), $homer ], #cheese => \\$marge, #bananas => Set::Object->new($homer, $marge), }; flatten($storage, $structure); is(ref $structure->{hello}, "Tangram::Memento", "blessed object removed - 2a"); is(ref $structure->{baz}->[2], "Tangram::Memento", "blessed object removed - 2b"); unflatten($storage, $structure); is($structure->{hello}, $homer, "unflatten - 2a"); is($structure->{baz}->[2], $homer, "unflatten - 2b"); $structure = { hello => $homer, foo => "bar", baz => [ qw(frop quux), $homer ], cheese => \\$marge, }; flatten($storage, $structure); is(ref $structure->{hello}, "Tangram::Memento", "blessed object removed - 3a"); is(ref $structure->{baz}->[2], "Tangram::Memento", "blessed object removed - 3b"); is(ref ${${$structure->{cheese}}}, "Tangram::Memento", "blessed object removed - 3c"); unflatten($storage, $structure); is($structure->{hello}, $homer, "unflatten - 3a"); is($structure->{baz}->[2], $homer, "unflatten - 3b"); is(${${$structure->{cheese}}}, $marge, "unflatten - 3c"); $structure = { hello => $homer, foo => "bar", baz => [ qw(frop quux), $homer ], cheese => \\$marge, bananas => Set::Object->new($homer, $marge), }; flatten($storage, $structure); isnt(ref $structure->{bananas}, "Set::Object", "Set::Object's replaced"); ###my $x = dispel_overload($structure->{bananas}); #isnt($x, 1, "no AMAGIC bits leaked"); unflatten($storage, $structure); is(ref $structure->{bananas}, "Set::Object", "unflatten Set::Object (container)"); is($structure->{bananas}->size, 2, "unflatten Set::Object (contents 1)"); is_deeply([ sort { $a->{firstName} cmp $b->{firstName} } $structure->{bananas}->members ], [ $homer, $marge ], "unflatten Set::Object (contents 2)"); $Data::Dumper::Indent = 1; #%$structure = (); delete $homer->{partner}; } is(leaked, 0, "leaktest"); # now test putting it in the database... { my $storage = Springfield::connect; my $homer = $storage->load($homer_id); $homer->{brains} = { me => $homer, marge => $homer->{partner}, #beer => "good", #beer_from => "fridge", #beer_fetched_by => \\$homer->{partner}, #family => Set::Object->new($homer, #$homer->{partner}) }; $storage->update($homer); delete $homer->{partner}; delete $homer->{brains}; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($homer_id); my $marge = $homer->{partner}; is($homer->{brains}->{marge}, $marge, "PerlDump can store Tangram objects!"); } Tangram-2.12/t/timeseries/0000755000175000017500000000000012605757355014160 5ustar samvsamvTangram-2.12/t/timeseries/00-schema.t0000644000175000017500000000043212605613635016011 0ustar samvsamv#!/usr/bin/perl -w BEGIN { $Tangram::TRACE = \*STDERR } use strict; use lib "t/timeseries"; use Prerequisites; use Test::More tests => 2; TimeSeries->deploy; ok("TimeSeries database deployed succesfully"); TimeSeries->retreat; ok("TimeSeries database retreated succesfully"); Tangram-2.12/t/timeseries/Prerequisites.pm0000644000175000017500000000020112605613635017343 0ustar samvsamv package Prerequisites; use lib "t"; use DBConfig; use TestNeeds qw(Test::More Time::HiRes Class::Tangram); use TimeSeries; 1; Tangram-2.12/t/timeseries/TimeSeries.pm0000644000175000017500000000151512605613635016561 0ustar samvsamv package TimeSeries; use Tangram::Schema; use Class::Tangram::Generator; use Tangram::Type::Date::TimeHiRes; use Tangram::Type::Interval::HiRes; our $schema = { classes => [ Event => { time_hires => { when => undef }, string => { who => undef, }, real => { clams => undef, }, iarray => { subsequent => { class => "Item" } }, }, Item => { interval_hires => { delta => undef, }, string => { what => undef, }, }, ], }; sub deploy { eval { &retreat }; $DBConfig::dialect->deploy($tangram_schema, DBConfig::cparm, ); } sub retreat { $DBConfig::dialect->retreat($tangram_schema, DBConfig::cparm, ($^S ? ({ RaiseError => 1, PrintError => 0 }) : () ) ); } Class::Tangram::Generator->new($schema); our $tangram_schema = Tangram::Schema->new($schema); Tangram-2.12/t/test_manifest0000644000175000017500000000162712605613635014575 0ustar samvsamvmisc/new_opers.t misc/bughunt.t misc/include.t misc/new_types.t misc/back-inflation.t springfield/00-deploy.t springfield/01-mappings.t springfield/02-cursor.t springfield/03-queries.t springfield/04-tx.t springfield/05-unload.t springfield/06-reload.t springfield/07-weakref.t springfield/15-datetime.t springfield/20-perldump.t springfield/21-flatarray.t springfield/22-flathash.t springfield/30-ref.t springfield/31-set.t springfield/32-iset.t springfield/33-array.t springfield/34-iarray.t springfield/35-hash.t springfield/36-ihash.t springfield/37-prefetch.t springfield/38-stateless.t springfield/39-save.t springfield/40-dump.t springfield/41-storable.t springfield/42-idbif.t springfield/70-mysql.t springfield/80-mi.t springfield/81-poly.t springfield/82-aggregate.t springfield/zz-retreat.t musicstore/00-deploy.t musicstore/01-simple.t musicstore/02-reorg.t musicstore/03-reschema.t musicstore/zz-retreat.t Tangram-2.12/t/misc/0000755000175000017500000000000012605757356012743 5ustar samvsamvTangram-2.12/t/misc/Fascisto.pm0000644000175000017500000000024112605613635015040 0ustar samvsamvpackage Fascisto; sub new { my $pkg = shift; my $foo = bless { $pkg->defaults, @_ }, $pkg; return $foo; } sub defaults { return (); } 1; __END__; Tangram-2.12/t/misc/RefImage.pm0000644000175000017500000000022512605613635014746 0ustar samvsamvpackage Tangram::RefImage; use Tangram qw(:compat_quiet); use base qw(Tangram::Ref); $Tangram::Schema::TYPES{ref_image} = Tangram::RefImage->new(); Tangram-2.12/t/misc/back-inflation.t0000644000175000017500000000363012605613635016002 0ustar samvsamv#!/usr/bin/perl use strict; use warnings; use lib "t"; use TestNeeds qw(Class::Tangram::Generator DBConfig); use Test::More tests => 11; BEGIN { use_ok('Tangram'); use_ok('Class::Tangram::Generator'); }; my $schemahash = { classes => { Hat => { fields => { string => [ qw( colour ) ], }, }, NaturalPerson => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iset => { hats => { class => 'Hat', back => 'owner', }, }, }, }, } }; my $schema = Tangram::Schema->new($schemahash); DBConfig->setup($schema); my $gen = Class::Tangram::Generator->new($schema); my $storage = Tangram::Relational->connect($schema, DBConfig->cparm); my $hat = $gen->new('Hat', colour => 'blue'); my $person = $gen->new('NaturalPerson', name => 'tangram'); $person->hats->insert($hat); ok(scalar $person->hats, 'hat given to owner'); $storage->insert($person); undef $person; undef $hat; $storage->recycle; ($person) = $storage->select('NaturalPerson'); ok(ref($person) eq 'NaturalPerson', 'person inserted and retrieved'); ($hat) = $person->hats; ok(ref($hat) eq 'Hat', 'person has a hat'); (my $owner) = $hat->owner; ok(ref($owner) eq 'NaturalPerson', 'owner of hat is a person'); use Scalar::Util qw(refaddr); is(refaddr($owner), refaddr($person), "same person"); ok(@{$owner->hats}, 'owner of hat has hats'); my $rem = $storage->remote('Hat'); ($hat) = $storage->select($rem, $rem->{owner} eq $person); ok(ref($hat) eq 'Hat', 'hat inserted and retrieved'); ($owner) = $hat->owner; ok(ref($owner) eq 'NaturalPerson', 'owner of hat is a person'); ok(@{$owner->hats}, 'owner of hat has hats'); Tangram-2.12/t/misc/include.t0000644000175000017500000000047312605616624014547 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 3; use vars qw($died); BEGIN { $SIG{__WARN__} = sub { $died++ }; use_ok(Tangram => qw(2.10_01), ":no_compat"); } is($died, undef, "didn't get a warning with a non-numeric version"); is($INC{"Tangram/Compat.pm"}, undef, "didn't use Tangram::Compat"); Tangram-2.12/t/misc/new_types.t0000644000175000017500000000201612605613635015133 0ustar samvsamv#!/usr/bin/perl -w # For bug: http://hottub.perlfect.com/pipermail/tangram-t2-maintainers/2003-November/000108.html use lib "t"; use TestNeeds qw(Set::Object); require "t/Capture.pm"; require "t/misc/RefImage.pm"; use strict; use Test::More tests => 1; use Tangram qw(:compat_quiet); use Tangram::Relational; use Tangram::Schema; my $schema = Tangram::Schema->new( classes => { 'Document' => { id => 1, fields => { ref_image => { image => { to => [ 'Image' ] } } }, bases => [ 'Base' ], table => 'Document', }, 'Base' => { id => 2, fields => { }, abstract => 1, table => 'Base', }, } ); my $output = new Capture(); $output->capture_print(); eval { Tangram::Relational->deploy($schema); }; is( $@, "", "schema with new type inheriting from Tangram::Ref doesn't die" ); my $result = $output->release_stdout(); Tangram-2.12/t/misc/bughunt.t0000644000175000017500000000422612605613635014577 0ustar samvsamv#!/usr/bin/perl -w # For bug: https://rt.cpan.org/NoAuth/Bug.html?id=2637 use lib "t"; use TestNeeds qw(Test::More Set::Object); require "t/Capture.pm"; use strict; use Test::More tests => 4; use Tangram qw(:compat_quiet); use Tangram::Relational; use Tangram::Schema; use Tangram::Scalar; use Tangram::Ref; use Tangram::IntrArray; my @tests = ( "iarray (Control)" => [ NaturalPerson => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iarray => { children => 'NaturalPerson' }, }, }, ], "iarray (w/Package seperator)" => [ 'Natural::Person' => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iarray => { children => 'Natural::Person' }, }, }, ], "iarray (w/Package seperator, long form)" => [ 'UnNatural::Person' => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iarray => { children => { class => 'UnNatural::Person', } }, }, }, ], "iarray (w/Package seperator, long form + coll/slot)" => [ 'Natural::Bloke' => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iarray => { children => { class => 'Natural::Bloke', coll => "foo", slot => "bar", } }, }, }, ], ); while (my ($test_name, $test_classes) = splice @tests, 0, 2) { my $schema = Tangram::Schema->new ( classes => $test_classes, normalize => sub { my ($name, $type) = @_; $name =~ s/\:\:/_/g; return $name; }, ); my $output = new Capture(); $output->capture_print(); Tangram::Relational->deploy($schema); my $result = $output->release_stdout(); $result =~ s{INSERT INTO Tangram.*}{}; unlike ($result, qr/::/, "Normalise applied - $test_name"); } Tangram-2.12/t/misc/new_opers.t0000644000175000017500000000421712605613635015124 0ustar samvsamv#!/usr/bin/perl -w # test new operators submitted by Ben Sommer use strict; use lib "t"; use lib "t/misc"; use TestNeeds qw(Set::Object); use DBConfig; use Test::More; my $db_cs = $DBConfig::cs || ''; if ($db_cs !~ /^dbi:Pg/) { plan skip_all => "Test without PostgreSQL"; } else { plan tests => 6; } require "t/Capture.pm"; use Tangram; use Tangram::Relational; use Tangram::Schema; my $schema = Tangram::Relational->schema( { classes => [ Fascisto => { fields => { string => [ qw( name rank ) ], int => [ qw( serialnumber ) ], } }, ] } ); my $output = new Capture(); $output->capture_print(); my @cp = ($db_cs, $DBConfig::user, $DBConfig::passwd); my $dbh = DBI->connect( @cp, { PrintError => 0 } ) or skip "could not connect to database", 1; eval { Tangram::Relational->retreat($schema, $dbh, { PrintError => 0 }) }; eval { Tangram::Relational->deploy($schema, $dbh) }; is( $@, "", "Fascists deployed!" ); my $result = $output->release_stdout(); my $storage = Tangram::Relational->connect( $schema, @cp ); use Fascisto; my $command_in_chief = Fascisto->new( name => 'GWB', rank => 'C.I.C.', serialnumber => 1, ); my $id = $storage->insert($command_in_chief) || 'no id'; ok($id && $id =~ /\d+/, 'got an ID'); undef $command_in_chief; my $fascisto = $storage->load($id); ok( ref $fascisto eq 'Fascisto', 'revived the not-long-for-this-world fascisto' ); my $fascisto_ = $storage->remote('Fascisto'); my ($fascisto_who_wont_die) = $storage->select ( $fascisto_, $fascisto_->{name}->match('~*', '^G*') ); ok( $fascisto_who_wont_die->{name} eq 'GWB', "hail the fascisto!" ); $fascisto_who_wont_die->{rank} = undef; $storage->update($fascisto_who_wont_die); my ($noname_fascisto) = $storage->select( $fascisto_, $fascisto_->{rank}->is_null ); #use Data::Dumper; #diag( Dumper($noname_fascisto) ); ok( $noname_fascisto->{name} eq 'GWB', 'going, going....' ); $storage->erase($noname_fascisto); my ($fascisto_alive) = $storage->select( $fascisto_, $fascisto_->{serialnumber} == 1); ok( ! $fascisto_alive, '...gone...phew!' ); 1; Tangram-2.12/t/Makefile0000644000175000017500000000015112605613635013434 0ustar samvsamv all: ( ls misc/*.t | sort; \ ls springfield/*.t | sort; \ ls musicstore/*.t | sort ) > test_manifest Tangram-2.12/t/DBConfig.pm0000644000175000017500000000276012605613635013755 0ustar samvsamv package DBConfig; use DBI; use Tangram qw(:core :compat_quiet); local $/; my $config = $ENV{TANGRAM_CONFIG} || 't/CONFIG'; open CONFIG, "$config" or die "Cannot open $config, reason: $!"; my ($tx, $subsel, $ttype); ($cs, $user, $passwd, $tx, $subsel, $ttype) = split "\n", ; if ($tx =~ m/(\d)/) { $no_tx = !$1; } if ($subsel =~ m/(\d)/) { $no_subselects = !$1; } if ($ttype =~ m/table_type\s*=\s*(.*)/) { $table_type = $1; } $vendor = (split ':', $cs)[1];; $dialect = "Tangram::$vendor"; # deduce dialect from DBI driver eval "use $dialect"; ($dialect = 'Tangram::Relational'), eval("use $dialect") if $@; print $Tangram::TRACE "Vendor driver $dialect not found - using ANSI SQL ($@)\n" if $@ and $Tangram::TRACE; if ($Tangram::TRACE) { print $Tangram::TRACE "DBConfig.pm: dialect = $dialect, cparm = $cs, " .($user ? "$user" : "(no user)").", " .($passwd ? ("x" x (length $passwd)) : "(no passwd)")."\n"; } our $AUTOLOAD; sub AUTOLOAD { shift if UNIVERSAL::isa($_[0], __PACKAGE__); $AUTOLOAD =~ s{.*::}{}; return $$AUTOLOAD; } sub cparm { return ($cs, $user, $passwd); } sub setup { my $class = shift if UNIVERSAL::isa($_[0], __PACKAGE__); $class ||= __PACKAGE__; my $schema = shift; my ($dsn, $u, $p) = $class->cparm; my $dbh = DBI->connect($dsn, $u, $p); eval { local $dbh->{RaiseError}; local $dbh->{PrintError}; Tangram::Relational->retreat($schema, $dbh); }; Tangram::Relational->deploy($schema, $dbh); } 1; Tangram-2.12/t/moose/0000755000175000017500000000000012605757355013131 5ustar samvsamvTangram-2.12/t/moose/CD.pm0000644000175000017500000000457612605613635013761 0ustar samvsamv package CD; use Moose; use Moose::Util::TypeConstraints; has 'title' => ( is => 'rw', isa => 'Str' ); has 'artist' => ( is => 'rw', isa => 'CD::Artist' ); has 'publishdate' => ( is => 'rw', isa => 'Time::Piece' ); # we need proper generics! this is silly subtype "Array of CD::Song" => as ArrayRef => where { (blessed($_) && $_->isa('CD::Song') || return) for @$_; 1 }; has 'songs' => ( is => 'rw', isa => 'Array of CD::Song' ); package CD::Compilation; use Moose; extends 'CD'; package CD::Song; use Moose; has 'name' => ( is => 'rw', isa => 'Str' ); package CD::Artist; use Moose; use Set::Object; has 'name' => ( is => 'rw', isa => 'Str' ); has 'popularity' => ( is => 'rw', isa => 'Str' ); use Moose::Util::TypeConstraints; subtype "Set of CD" => as Set::Object => where { ($_->isa('CD') || return) for $_->members; 1 }; has 'cds' => ( is => 'rw', isa => 'Set of CD' ); package CD::Person; use Moose; use Moose::Util::TypeConstraints; extends 'CD::Artist'; enum "Gender" => qw(Male Female Asexual Hemaphrodite); has 'gender' => ( is => 'rw', isa => "Gender" ); has 'haircolor' => ( is => 'rw', isa => "Str" ); has 'birthdate' => ( is => 'rw', isa => 'Time::Piece' ); package CD::Band; use Moose; use Moose::Util::TypeConstraints; extents 'CD::Artist'; subtype "Set of CD::Person" => as Set::Object => where { ($_->isa('CD::Artist') || return) for $_->members; 1 }; has 'members' => ( is => 'rw', isa => 'Set of CD::Person' ); has 'creationdate' => ( is => 'rw', isa => 'Time::Piece' ); has 'enddate' => ( is => 'rw', isa => 'Time::Piece' ); sub CD::addone { $CD::c++ } sub CD::delone { --$CD::c } # for running tests, we keep a count of objects created BEGIN { for my $package ( qw(CD CD::Song CD::Artist CD::Person CD::Band) ) { eval " package $package; before 'new' => \&CD::addone; after 'DESTROY' => \&CD::delone;"; } } # This dispatching isn't necessary because we use inheritance # # Dispatch "band" accessors if it's a band # for my $accessor (qw(members creationdate breakupdate)) { # *$accessor = sub { # my $self = shift; # return $self->band->$accessor(@_) if $self->band # }; # } # # And dispatch "person" accessors if it's a person # for my $accessor (qw(gender haircolor birthdate)) { # *$accessor = sub { # my $self = shift; # return $self->person->$accessor(@_) if $self->person # }; # } 1; Tangram-2.12/t/orange/0000755000175000017500000000000012605757355013262 5ustar samvsamvTangram-2.12/t/orange/hello-tangram.pl0000644000175000017500000000177612605613635016354 0ustar samvsamv#!/usr/bin/perl # # the missing bare bones example, from Sebastian Riedel. # use DBI; use Tangram; use Class::Tangram::Generator; my $schema = Tangram::Schema->new( { classes => [ Orange => { fields => { int => [qw(juicyness ripeness)] }, methods => { squeeze => sub { my $self = shift; $self->juicyness( $self->juicyness() - 1 ); }, eviscerate => sub { my $self = shift; $self->juicyness(0); }, } } ] } ); if ( $ARGV[0] ) { my $dbh = DBI->connect('dbi:SQLite:test.db'); Tangram::Relational->deploy( $schema, $dbh ); } my $gen = Class::Tangram::Generator->new($schema); my $storage = Tangram::Relational->connect( $schema, 'dbi:SQLite:test.db' ); my $orange = $gen->new('Orange'); $orange->juicyness(20); $storage->insert($orange); Tangram-2.12/t/TestNeeds.pm0000644000175000017500000000155512605613635014241 0ustar samvsamv package TestNeeds; use Data::Dumper; sub import { my $package = shift; my $caller = caller(); my @missing; while ( my $package = shift ) { my $import = ""; if ( @_ and ref $_[0] ) { local($Data::Dumper::Purity) = 1; $import = Data::Dumper::Dumper(${(shift)}); } elsif ( @_ and $_[0] =~ m/^[0-9\.\-][\w\-\.]*$/) { $import = shift; } eval "package $caller; use $package $import;"; push @missing, $package, $import, $@ if $@; } if ( @missing ) { print("1..0 # Skip missing/broken dependancies"); if ( 0 and -t STDOUT ) { print "\n"; while ( my ($pkg, $args, $err) = splice @missing, 0, 3 ) { print STDERR ("ERROR - pre-requisite $pkg " .($args ? "$args " : "") ."failed to load ($err)\n"); } } else { print "; ".join(", ", grep { !($i++ % 3) } @missing)."\n"; } exit(0); } } 1; Tangram-2.12/t/Capture.pm0000644000175000017500000000162512605613635013744 0ustar samvsamv# a small package to capture standard output, so that we can test the # output of Tangram::Relational->deploy() { package Capture; sub new { my $class = shift; my $self = { stdout => "" }; bless $self, $class; return $self; } sub capture_print { my $self = shift; $self->{so} = tie(*STDOUT, __PACKAGE__, \$self->{stdout}) or die "failed to tie STDOUT; $!"; } sub release_stdout { my $self = shift; delete $self->{so}; untie(*STDOUT); return $self->{stdout}; } sub TIEHANDLE { my $class = shift; my $ref = shift; return bless({ stdout => $ref }, $class); } sub PRINT { my $self = shift; ${$self->{stdout}} .= join('', map { defined $_?$_:""} @_); } sub PRINTF { my ($self) = shift; print STDERR "OUCH @_\n"; my ($fmt) = shift; ${$self->{stdout}} .= sprintf($fmt, @_) if (@_); } sub glob { return \*STDOUT; } } 1; Tangram-2.12/t/rt/0000755000175000017500000000000012605757355012434 5ustar samvsamvTangram-2.12/t/rt/RT.pm0000644000175000017500000002541312605613635013314 0ustar samvsamv # an example schema, modeled after Request Tracker. package RT; BEGIN { use base qw(Exporter); our @EXPORT_OK = qw($schema); } our $schema = { sql => { type_col => "t2_type", }, classes => [ RT::Attachment => { fields => { # back-refs: Transaction iset => { Children => { class => "RT::Attachment", back => "Parent", aggreg => 1, }, }, string => { MessageId => { sql => "varchar(160)" }, Subject => { sql => "varchar(255)" }, Filename => { sql => "varchar(255)" }, ContentType => { sql => "varchar(80)" }, ContentEncoding => { sql => "varchar(80)" }, Content => { sql => "LONGTEXT" }, Headers => { sql => "LONGTEXT" }, }, ref => { Creator => undef, }, dmdatetime => [ qw(Created) ], }, }, RT::Queue => { fields => { string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, CorrespondAddress => { sql => "varchar(120)" }, CommentAddress => { sql => "varchar(120)" }, }, int => [ qw(InitialPriority FinalPriority DefaultDueIn Disabled) ], ref => { LastUpdatedBy => undef, Creator => undef, }, # FIXME - need an on-demand loader that can load partial # contents of containers, this mapping is awful. # In reality, you would never actually load relationships # like "Tickets", you'd use the relationship to query. iset => { Scrips => { class => "RT::Scrip", aggreg => 1, back => "Queue", }, Tickets => { class => "RT::Ticket", aggreg => 1, back => "Queue", }, Templates => { class => "RT::Template", aggreg => 1, back => "Queue", }, }, iarray => { CustomFields => { class => "RT::CustomField", aggreg => 1, back => "Queue", }, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Link => { fields => { string => { Base => { sql => "varchar(240)" }, Target => { sql => "varchar(240)" }, Type => { sql => "varchar(20)" }, }, int => [ # FIXME - are these links? qw(LocalTarget LocalBase) ], ref => { LastUpdatedBy => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Principal => { fields => { string => { PrincipalType => { sql => "varchar(16)" }, }, ref => { # to users or groups, depending ObjectId => undef, }, iset => { ACLs => { class => "RT::ACL", aggreg => 1, back => "Principal", }, }, int => [ qw(Disabled) ], }, }, RT::Group => { fields => { string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, Domain => { sql => "varchar(64)" }, Type => { sql => "varchar(64)" }, }, # FIXME - is this actually a ref? int => [ qw(Instance) ], set => { Members => { class => "RT::User", table => "GroupMembers", }, }, }, }, RT::ScripCondition => { fields => { string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, ExecModule => { sql => "varchar(60)" }, Argument => { sql => "varchar(255)" }, ApplicableTransTypes => { sql => "varchar(60)" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Transaction => { fields => { #back-refs: Ticket ref => { EffectiveTicket => undef, Creator => undef, }, int => { TimeTaken => undef, }, string => { Type => { sql => "varchar(20)" }, Field => { sql => "varchar(40)" }, OldValue => { sql => "varchar(255)" }, NewValue => { sql => "varchar(255)" }, Data => { sql => "varchar(255)" }, }, dmdatetime => [ qw(Created) ], iset => { Attachments => { class => "RT::Attachment", back => "Transaction", aggreg => 1, }, }, }, }, RT::Scrip => { fields => {#back-refs: Queue string => { Description => { sql => "varchar(255)" }, Stage => { sql => "varchar(32)" }, ConditionRules => { sql => "text" }, ActionRules => { sql => "text" }, CustomIsApplicableCode => { sql => "text" }, CustomPrepareCode => { sql => "text" }, CustomCommitCode => { sql => "text" }, }, ref => { Template => undef, LastUpdatedBy => undef, Creator => undef, ScripCondition => undef, ScripAction => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::ACL => { fields => {#back-refs: Principal string => { #"User" "Group", "Owner", "Cc" "AdminCc", # "Requestor", "Requestor" PrincipalType => { sql => "varchar(25)" }, RightName => { sql => "varchar(25)" }, # FIXME - probably unnecessary ObjectType => { sql => "varchar(25)" }, }, ref => { Object => undef, # Principal with a user DelegatedBy => undef, # another ACL DelegatedFrom => undef, }, }, }, # this table represents a de-normalisation of a tree. Because # trees just aren't normal. RT::CachedGroupMember => { fields => { ref => { Group => undef, # RT::Principal Member => undef, # RT::Principal Via => undef, # RT::CachedGroupMember # RT::Prinicpal # this points to the group that the member is # a member of, for ease of deletes. ImmediateParent => undef, }, int => { #if this cached group member is a member of this # group by way of a disabled group or this group is # disabled, this will be set to 1 this allows us to # not find members of disabled subgroups when # listing off group members recursively. Also, # this allows us to have the ACL system elide # members of disabled groups Disabled => undef, }, }, }, RT::User => { fields => { string => { Name => { sql => "varchar(200)" }, Password => { sql => "varchar(40)" }, Comments => { sql => "BLOB" }, Signature => { sql => "BLOB" }, EmailAddress => { sql => "varchar(120)" }, FreeformContactInfo => { sql => "BLOB" }, Organization => { sql => "varchar(200)" }, RealName => { sql => "varchar(120)" }, NickName => { sql => "varchar(16)" }, Lang => { sql => "varchar(16)" }, EmailEncoding => { sql => "varchar(16)" }, WebEncoding => { sql => "varchar(16)" }, ExternalContactInfoId => { sql => "varchar(100)" }, ContactInfoSystem => { sql => "varchar(30)" }, ContactInfoSystem => { sql => "varchar(30)" }, ExternalAuthId => { sql => "varchar(100)" }, AuthSystem => { sql => "varchar(30)" }, Gecos => { sql => "varchar(16)" }, HomePhone => { sql => "varchar(30)" }, WorkPhone => { sql => "varchar(30)" }, MobilePhone => { sql => "varchar(30)" }, PagerPhone => { sql => "varchar(30)" }, Address1 => { sql => "varchar(200)" }, Address2 => { sql => "varchar(200)" }, City => { sql => "varchar(100)" }, State => { sql => "varchar(100)" }, Zip => { sql => "varchar(16)" }, Country => { sql => "varchar(50)" }, Timezone => { sql => "varchar(50)" }, PGPKey => { sql => "TEXT" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Ticket => { fields => { #backrefs: Queue int => [ qw(EffectiveId IssueStatement Resolution InitialPriority FinalPriority Priority TimeEstimated TimeWorked TimeLeft Disabled ) ], string => { Type => { sql => "varchar(16)" }, Subject => { sql => "varchar(200)" }, Status => { sql => "varchar(10)" }, }, dmdatetime => [ qw(Told Starts Started Due Resolved) ], ref => { Owner => undef, LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::ScripAction => { fields => { string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, ExecModule => { sql => "varchar(60)" }, Argument => { sql => "varchar(255)" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::Template => { fields => { #backrefs: Queue string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, Type => { sql => "varchar(16)" }, Language => { sql => "varchar(16)" }, Content => { sql => "BLOB" }, }, iset => { Translations => { class => "RT::Template", #aggreg => 1, back => "TranslationOf", }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::TicketCustomFieldValue => { fields => { # backrefs: Ticket string => { Name => { Content => "varchar(255)" } }, ref => { CustomField => undef, LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::CustomField => { fields => { # backrefs: Queue string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, Type => { sql => "varchar(200)" }, Language => { sql => "varchar(16)" }, Content => { sql => "BLOB" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], int => [ qw(Disabled) ], iarray => { Values => { class => "RT::CustomFieldValue", back => "CustomField", aggreg => 1, }, }, }, }, # RT::CustomFieldValue => { fields => { # backrefs: CustomField string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::Attribute => { fields => { string => { Name => { sql => "varchar(255)" }, Description => { sql => "varchar(255)" }, Content => { sql => "TEXT" }, ContentType => { sql => "varchar(16)" }, # FIXME - not necessary? ObjectType => { sql => "varchar(64)" }, }, ref => { LastUpdatedBy => undef, Creator => undef, Object => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Session => { fields => { ref => { LoggedInUser => undef, }, idbif => { -poof => # there goes another one! }, dmdatetime => { LastUpdated => { sql => "TIMESTAMP" } }, }, }, ], }; 1; Tangram-2.12/t/rt/RT.pod0000644000175000017500000003346312605613635013466 0ustar samvsamv=head1 NAME t/eg/RT.pm - example schema, based on Request Tracker =head1 SYNOPSIS use RT qw($schema); use Tangram; my $storage = Tangram::Storage->connect (Tangram::Schema->new($schema), $dsn, $u, $p, ); =head1 DESCRIPTION This package is a re-modelling of the Request Tracker 3.0.9 database schema to Tangram. See the F file in the distribution for more information. =head2 Request Tracker Request Tracker is a trouble ticketing system. See L for more. The site, L, runs on RT. Request Tracker, as an application, is a Mason application written using an abstraction library called L. =head1 METHOD The method for this is fairly simple, once you know how Tangram maps classes to tables. Interested readers are urged to first read L. First, The MySQL schema was manually converted to a Tangram schema, table by table. This process took about 60-90 minutes. Where possible, obvious foreign key relationships and foreign key with `SortOrder' columns were converted to Tangram::IntrSet and Tangram::IntrArray relationship, respectively. One table, GroupMembers, was done away with entirely. In several places, there is use of a "Type" column. It is suspected that this often could have been done away with - as all L fields by default can point to any class, this sort of carry-on is seldom necessary. =head1 APPENDICES =head2 Appendix A - RT database schema The following SQL file was used for the conversion, and # {{{ Attachments CREATE TABLE Attachments ( id INTEGER NOT NULL AUTO_INCREMENT, TransactionId integer NOT NULL , Parent integer NOT NULL DEFAULT 0 , MessageId varchar(160) NULL , Subject varchar(255) NULL , Filename varchar(255) NULL , ContentType varchar(80) NULL , ContentEncoding varchar(80) NULL , Content LONGTEXT NULL , Headers LONGTEXT NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Attachments2 ON Attachments (TransactionId) ; CREATE INDEX Attachments3 ON Attachments (Parent, TransactionId) ; # }}} # {{{ Queues CREATE TABLE Queues ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NOT NULL , Description varchar(255) NULL , CorrespondAddress varchar(120) NULL , CommentAddress varchar(120) NULL , InitialPriority integer NOT NULL DEFAULT 0 , FinalPriority integer NOT NULL DEFAULT 0 , DefaultDueIn integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , Disabled int2 NOT NULL DEFAULT 0 , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE UNIQUE INDEX Queues1 ON Queues (Name) ; CREATE INDEX Queues2 ON Queues (Disabled) ; # }}} # {{{ Links CREATE TABLE Links ( id INTEGER NOT NULL AUTO_INCREMENT, Base varchar(240) NULL , Target varchar(240) NULL , Type varchar(20) NOT NULL , LocalTarget integer NOT NULL DEFAULT 0 , LocalBase integer NOT NULL DEFAULT 0 , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE UNIQUE INDEX Links1 ON Links (Base, Target, Type) ; CREATE INDEX Links2 ON Links (Base, Type) ; CREATE INDEX Links3 ON Links (Target, Type) ; CREATE INDEX Links4 ON Links (Type,LocalBase); # }}} # {{{ Principals CREATE TABLE Principals ( id INTEGER AUTO_INCREMENT not null, PrincipalType VARCHAR(16) not null, ObjectId integer, # foreign key to Users or Groups, depending Disabled int2 NOT NULL DEFAULT 0 , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Principals2 ON Principals (ObjectId); # }}} # {{{ Groups CREATE TABLE Groups ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NULL , Description varchar(255) NULL , Domain varchar(64), Type varchar(64), Instance integer, PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Groups1 ON Groups (Domain,Instance,Type,id); CREATE INDEX Groups2 On Groups (Type, Instance); # }}} # {{{ ScripConditions CREATE TABLE ScripConditions ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NULL , Description varchar(255) NULL , ExecModule varchar(60) NULL , Argument varchar(255) NULL , ApplicableTransTypes varchar(60) NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; # }}} # {{{ Transactions CREATE TABLE Transactions ( id INTEGER NOT NULL AUTO_INCREMENT, EffectiveTicket integer NOT NULL DEFAULT 0 , Ticket integer NOT NULL DEFAULT 0 , TimeTaken integer NOT NULL DEFAULT 0 , Type varchar(20) NULL , Field varchar(40) NULL , OldValue varchar(255) NULL , NewValue varchar(255) NULL , Data varchar(255) NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Transactions1 ON Transactions (Ticket); CREATE INDEX Transactions2 ON Transactions (EffectiveTicket); # }}} # {{{ Scrips CREATE TABLE Scrips ( id INTEGER NOT NULL AUTO_INCREMENT, Description varchar(255), ScripCondition integer NOT NULL DEFAULT 0 , ScripAction integer NOT NULL DEFAULT 0 , ConditionRules text NULL , ActionRules text NULL , CustomIsApplicableCode text NULL , CustomPrepareCode text NULL , CustomCommitCode text NULL , Stage varchar(32) NULL , Queue integer NOT NULL DEFAULT 0 , Template integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; # }}} # {{{ ACL CREATE TABLE ACL ( id INTEGER NOT NULL AUTO_INCREMENT, PrincipalType varchar(25) NOT NULL, #"User" "Group", "Owner", "Cc" "AdminCc", "Requestor", "Requestor" PrincipalId integer NOT NULL , #Foreign key to principals RightName varchar(25) NOT NULL , ObjectType varchar(25) NOT NULL , ObjectId integer NOT NULL default 0, DelegatedBy integer NOT NULL default 0, #foreign key to principals with a userid DelegatedFrom integer NOT NULL default 0, #foreign key to ACL PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX ACL1 on ACL(RightName, ObjectType, ObjectId,PrincipalType,PrincipalId); # }}} # {{{ GroupMembers CREATE TABLE GroupMembers ( id INTEGER NOT NULL AUTO_INCREMENT, GroupId integer NOT NULL DEFAULT 0, MemberId integer NOT NULL DEFAULT 0, #Foreign key to Principals PRIMARY KEY (id) ) TYPE=InnoDB; CREATE UNIQUE INDEX GroupMembers1 on GroupMembers (GroupId, MemberId); # }}} # {{{ GroupMembersCache create table CachedGroupMembers ( id int auto_increment, GroupId int, # foreign key to Principals MemberId int, # foreign key to Principals Via int, #foreign key to CachedGroupMembers. (may point to $self->id) ImmediateParentId int, #foreign key to prinicpals. # this points to the group that the member is # a member of, for ease of deletes. Disabled int2 NOT NULL DEFAULT 0 , # if this cached group member is a member of this group by way of a disabled # group or this group is disabled, this will be set to 1 # this allows us to not find members of disabled subgroups when listing off # group members recursively. # Also, this allows us to have the ACL system elide members of disabled groups PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX DisGrouMem on CachedGroupMembers (GroupId,MemberId,Disabled); # }}} # {{{ Users CREATE TABLE Users ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NOT NULL , Password varchar(40) NULL , Comments blob NULL , Signature blob NULL , EmailAddress varchar(120) NULL , FreeformContactInfo blob NULL , Organization varchar(200) NULL , RealName varchar(120) NULL , NickName varchar(16) NULL , Lang varchar(16) NULL , EmailEncoding varchar(16) NULL , WebEncoding varchar(16) NULL , ExternalContactInfoId varchar(100) NULL , ContactInfoSystem varchar(30) NULL , ExternalAuthId varchar(100) NULL , AuthSystem varchar(30) NULL , Gecos varchar(16) NULL , HomePhone varchar(30) NULL , WorkPhone varchar(30) NULL , MobilePhone varchar(30) NULL , PagerPhone varchar(30) NULL , Address1 varchar(200) NULL , Address2 varchar(200) NULL , City varchar(100) NULL , State varchar(100) NULL , Zip varchar(16) NULL , Country varchar(50) NULL , Timezone varchar(50) NULL , PGPKey text NULL, Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE UNIQUE INDEX Users1 ON Users (Name) ; CREATE INDEX Users4 ON Users (EmailAddress); # }}} # {{{ Tickets CREATE TABLE Tickets ( id INTEGER NOT NULL AUTO_INCREMENT, EffectiveId integer NOT NULL DEFAULT 0 , Queue integer NOT NULL DEFAULT 0 , Type varchar(16) NULL , IssueStatement integer NOT NULL DEFAULT 0 , Resolution integer NOT NULL DEFAULT 0 , Owner integer NOT NULL DEFAULT 0 , Subject varchar(200) NULL DEFAULT '[no subject]' , InitialPriority integer NOT NULL DEFAULT 0 , FinalPriority integer NOT NULL DEFAULT 0 , Priority integer NOT NULL DEFAULT 0 , TimeEstimated integer NOT NULL DEFAULT 0 , TimeWorked integer NOT NULL DEFAULT 0 , Status varchar(10) NULL , TimeLeft integer NOT NULL DEFAULT 0 , Told DATETIME NULL , Starts DATETIME NULL , Started DATETIME NULL , Due DATETIME NULL , Resolved DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , Disabled int2 NOT NULL DEFAULT 0 , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Tickets1 ON Tickets (Queue, Status) ; CREATE INDEX Tickets2 ON Tickets (Owner) ; CREATE INDEX Tickets6 ON Tickets (EffectiveId, Type) ; # }}} # {{{ ScripActions CREATE TABLE ScripActions ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NULL , Description varchar(255) NULL , ExecModule varchar(60) NULL , Argument varchar(255) NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; # }}} # {{{ Templates CREATE TABLE Templates ( id INTEGER NOT NULL AUTO_INCREMENT, Queue integer NOT NULL DEFAULT 0 , Name varchar(200) NOT NULL , Description varchar(255) NULL , Type varchar(16) NULL , Language varchar(16) NULL , TranslationOf integer NOT NULL DEFAULT 0 , Content blob NULL , LastUpdated DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; # }}} # {{{ TicketCustomFieldValues CREATE TABLE TicketCustomFieldValues ( id INTEGER NOT NULL AUTO_INCREMENT, Ticket int NOT NULL , CustomField int NOT NULL , Content varchar(255) NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX TicketCustomFieldValues1 ON TicketCustomFieldValues (CustomField,Ticket,Content); # }}} # {{{ CustomFields CREATE TABLE CustomFields ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NULL , Type varchar(200) NULL , Queue integer NOT NULL DEFAULT 0 , Description varchar(255) NULL , SortOrder integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , Disabled int2 NOT NULL DEFAULT 0 , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX CustomFields1 on CustomFields (Disabled, Queue); # }}} # {{{ CustomFieldValues CREATE TABLE CustomFieldValues ( id INTEGER NOT NULL AUTO_INCREMENT, CustomField int NOT NULL , Name varchar(200) NULL , Description varchar(255) NULL , SortOrder integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX CustomFieldValues1 ON CustomFieldValues (CustomField); # }}} # {{{ Attributes CREATE TABLE Attributes ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(255) NULL , Description varchar(255) NULL , Content text, ContentType varchar(16), ObjectType varchar(64), ObjectId integer, # foreign key to anything Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Attributes1 on Attributes(Name); CREATE INDEX Attributes2 on Attributes(ObjectType, ObjectId); # }}} # {{{ Sessions # sessions is used by Apache::Session to keep sessions in the database. # We should have a reaper script somewhere. CREATE TABLE sessions ( id char(32) NOT NULL, a_session LONGTEXT, LastUpdated TIMESTAMP, PRIMARY KEY (id) ); # }}} =cut Tangram-2.12/t/musicstore/0000755000175000017500000000000012605757355014204 5ustar samvsamvTangram-2.12/t/musicstore/CD.pm0000644000175000017500000000273212605613635015024 0ustar samvsamv package CD; our $c; use base "Class::Accessor::Assert"; __PACKAGE__->mk_accessors(qw( artist=CD::Artist title publishdate=Time::Piece songs=ARRAY )); package CD::Compilation; use base 'CD'; package CD::Song; use base 'Class::Accessor'; __PACKAGE__->mk_accessors("name"); package CD::Artist; use base 'Class::Accessor::Assert'; __PACKAGE__->mk_accessors(qw( name popularity cds=Set::Object )); package CD::Person; use base 'CD::Artist'; __PACKAGE__->mk_accessors(qw(gender haircolor birthdate=Time::Piece)); package CD::Band; use base 'CD::Artist'; __PACKAGE__->mk_accessors( qw( members=Set::Object creationdate=Time::Piece enddate=Time::Piece )); # for running tests, we keep a count of objects created BEGIN { for my $package ( qw(CD CD::Song CD::Artist CD::Person CD::Band) ) { sub new { $CD::c++; my $invocant = shift; $invocant->SUPER::new(@_); } sub DESTROY { --$CD::c; } } } # This dispatching isn't necessary because we use inheritance # # Dispatch "band" accessors if it's a band # for my $accessor (qw(members creationdate breakupdate)) { # *$accessor = sub { # my $self = shift; # return $self->band->$accessor(@_) if $self->band # }; # } # # And dispatch "person" accessors if it's a person # for my $accessor (qw(gender haircolor birthdate)) { # *$accessor = sub { # my $self = shift; # return $self->person->$accessor(@_) if $self->person # }; # } 1; Tangram-2.12/t/musicstore/02-reorg.t0000644000175000017500000000505312605613635015721 0ustar samvsamv# -*- perl -*- # in this script, we re-org the database by loading in objects from # one storage and saving them in another. use lib "t/musicstore"; use lib "t"; use Prerequisites; use TestNeeds qw(Heritable::Types 1.01); use Set::Object; use Test::More tests => 6; my $cd = new CD; # to make things interesting, we put the data into a single table, # which turns our nice relational database into an old school # heirarchical database. After all, unless you have a radical schema # change, this whole operation of a re-org is pretty pointless! my $storage = DBConfig->dialect->connect (MusicStore->schema, DBConfig->cparm); # some DBI drivers (eg, Informix) don't like two connections from the # same process my $storage2 = DBConfig->dialect->connect (MusicStore->pixie_like_schema, DBConfig->cparm); my @classes = qw(CD CD::Artist CD::Song); # the simplest way would be to use something akin to this: # # $storage2->insert(map { $storage->select($_) } @classes); # # however, this exposes one of the caveats with such an "open slander # insertion" policy. # If you let any node in an object structure be inserted as an object, # automatically storing all its sub-trees, there is no easy way to see # if a given node that is being inserted isn't already a sub-part of # another stored node. # My intention is to make Tangram::Storage->insert() take care of this # for you. I can see this working within the next two Tangram # releases: # why bother with a database if you're just going to load it into # memory, you might ask? Well, this test script is demo-ing the # reschema support. my @objects = map { $storage->select($_) } @classes; # we insert only CD objects into $storage2. my @cds = grep { $_->isa("CD") } @objects; $storage2->insert( @cds ); # later; # $storage2->insert($storage->select("CD")); my $unknown = set(); my %known; for my $object ( @objects ) { if ( my $oid = $storage2->id($object) ) { $known{$oid} = $object; } else { $unknown->insert($object); } } is( keys %known, @cds, "number of objects inserted"); is( (grep { $_->isa("CD") } values %known), (keys %known), "all inserted objects are CDs"); is( $unknown->size, (@objects - @cds), "correct number of uninserted objects") is( (grep { ! $_->isa("CD") } $unknown->members), $unknown->size, "no uninserted objects are CDs"); $storage2->unload_all(); is( (grep { $_ } $storage2->id( @objects ) ), 0, "unload forgets the objects" ); is_deeply( [ sort @cds ], [ sort $storage2->select("CD") ], "but they are still the same objects!" ); Tangram-2.12/t/musicstore/insert_extra_data.pl0000644000175000017500000001111312605613635020226 0ustar samvsamv # $storage is defined # normally, for this sort of thing I'd use YAML { my ($members, $syd, $bob, $gilmour, @junk); my @bands = ( CD::Band->new ({ name => "The English Beat", popularity => "one hit wonder", cds => Set::Object->new ( CD->new({ title => "Beat This: The Best of the English Beat", publishdate => iso("2001-09-11"), # (!) songs => [ map { CD::Song->new({ name => $_}) } "Mirror In The Bathroom", "Best Friend", "Hands Off She's Mine", "Too Nice To Talk To", "Doors Of Your Heart", "I Confess", "Twist And Crawl", "Rankin Full Stop", "Drowning", "Save It For Later", "Sole Salvation", "Click Click", "Tears Of A Clown", "Can't Get Used To Losing You", "Stand Down Margaret", ] }), CD->new({ title => "Special Meat Service", publishdate => iso("1999-10-26"), songs => [ map { CD::Song->new({name => $_}) } "I Confess", "Jeannette", "Sorry", "Sole Salvation", "Spar Wid Me", "Rotating Heads", "Save It For Later", "She's Going", "Pato and Roger A Go Talk", "Sugar and Stress", "End of the Party", ], }) ), members => Set::Object->new ( map { CD::Person->new({ name => $_ }) } "David Steele", "Saxa", "Everett Morton", "Wesley Magoogan", "Andy Cox", "Ranking Roger", "Dave Wakeling", ), }), CD::Band->new ({ name => "The Pink Floyd", popularity => "fledgling", creationdate => iso("1964"), enddate => iso("1968"), cds => Set::Object->new ( CD->new({ title => "The Piper At the Gates of Dawn", publishdate => iso("1967"), songs => [ map { CD::Song->new({name => $_}) } "Astronomy Domine", "Lucifer Sam", "Matilda Mother", "Flaming", "Pow R. Toc H.", "Take Up Thy Stethoscope and Walk", "Interstellar Overdrive", "The Gnome", "Chapter 24", "Scarecrow", "Bike", ] }), ), members => $members=Set::Object->new ( ($syd, $bob, @junk) = map { CD::Person->new({ name => $_ }) } "Syd Barrett", "Bob Klose", "Richard Wright", "Roger Waters", "Nick Mason (drums)", ), }), CD::Band->new ({ name => "The Pink Floyd", popularity => "increasing", creationdate => iso("1968"), enddate => iso("1969"), cds => Set::Object->new ( CD->new({ title => "A Saucerful of Secrets", publishdate => iso("1968"), songs => [ map { CD::Song->new({name => $_}) } "Let There Be More Light", "Remember A Day", "Set The Controls For The Heart Of The Sun", "Corporal Clegg", "A Saucerful of Secrets", "See-Saw", "Jugband Blues", ] }), ), members => Set::Object->new ( $members->members, ($gilmour = CD::Person->new({ name => "David Gilmour" })) ), }), CD::Band->new ({ name => "Pink Floyd", popularity => "great", creationdate => iso("1969"), cds => Set::Object->new ( CD->new({ title => "Ummagumma (disc 1 - live disc)", publishdate => iso("1969-10-25"), songs => [ map { CD::Song->new({name => $_}) } "Astronomy Domine", "Careful With That Axe, Eugene", "Set The Controls For The Heart of The Sun", "A Saucerful of Secrets", ] }), CD->new({ title => "Ummagumma (disc 2 - studio disc)", publishdate => iso("1969-10-25"), songs => [ map { CD::Song->new({name => $_}) } "Sysyphus Part 1", "Sysyphus Part 2", "Sysyphus Part 3", "Sysyphus Part 4", "Grantchester Meadows", "Several Species Of Small Furry Animals Gathered In A Cave And Grooving With A Pict", "The Narrow Way Part 1", "The Narrow Way Part 2", "The Narrow Way Part 3", "The Grand Vizier's Garden Party Part 1\u2014Entrance", "The Grand Vizier's Garden Party Part 2\u2014Entertainment", "The Grand Vizier's Garden Party Part 3\u2014Exit", ] }), ), members => Set::Object->new ( ( ($members - Set::Object->new($syd, $bob))->members, $gilmour, ), ) }), CD::Band->new ({ name => "Damnwells", popularity => "fringe", cds => Set::Object->new ( CD->new({ title => "Bastards of the Beat", publishdate => iso("2004-04-06"), songs => [ map { CD::Song->new({name => $_}) } "A******s", "What You Get", "Kiss Catastrophe", "I'll Be Around", "Newborn History", "I Will Keep The Bad Things From You", "Sleepsinging", "The Sound", "The Lost Complaint", "Electrric Harmony", "New Delhi", "Star / Fool", ], }), ), members => Set::Object->new ( map { CD::Person->new({ name => $_ }) } "Alex Dezen", "David Chernis", "Ted Hudson", "Steven Terry" ) }) ); $storage->insert(@bands); } 1; Tangram-2.12/t/musicstore/03-reschema.t0000644000175000017500000000134512605613635016373 0ustar samvsamv# -*- perl -*- # Kill two birds with one stone; re-org and reschema use lib "t/musicstore"; use Prerequisites; use strict; use Test::More tests => 4; use Tangram::Storage; my $old_schema = MusicStore->schema; my $new_schema = MusicStore->new_schema; DBConfig->dialect->deploy($new_schema, DBConfig->cparm); pass("deployed new schema successfully"); { my $storage_old = DBConfig->dialect->connect($old_schema, DBConfig->cparm); pass("connected to old schema"); my $storage_new = DBConfig->dialect->connect($new_schema, DBConfig->cparm); pass("connected to new schema"); my @oids = $storage_new->insert($storage_old->select("CD::Artist")); pass("inserted data into database (new oids: @oids)"); } __END__ Tangram-2.12/t/musicstore/MusicStore.pm0000644000175000017500000000476412605613635016642 0ustar samvsamv package MusicStore; use CD; use Tangram qw(:core :compat_quiet); use Tangram::Schema; use Tangram::IntrArray; use Tangram::TimePiece; use Tangram::IntrSet; use Tangram::Set; use Tangram::IDBIF; our $schema = ({ classes => [ CD => { fields => { string => [ qw(title) ], timepiece => [ qw(publishdate) ], iarray => { songs => { class => 'CD::Song', aggreg => 1, back => 'cd', }, }, } }, CD::Song => { fields => { string => [ qw(name) ], } }, CD::Artist => { abstract => 1, fields => { string => [ qw(name popularity) ], iset => { cds => { class => 'CD', aggreg => 1, back => 'artist' }, }, }, }, CD::Person => { bases => [ "CD::Artist" ], fields => { string => [ qw(gender haircolor) ], timepiece => [ qw(birthdate) ], } }, CD::Band => { bases => [ "CD::Artist" ], fields => { timepiece => [ qw(creationdate enddate) ], set => { members => { class => 'CD::Person', table => "artistgroup", }, }, }, }, ], }); our $pixie_like_schema = ({ classes => [ HASH => { table => "objects", sql => { sequence => "oid_sequence" }, fields => { idbif => undef }, }, ], }); use Storable qw(dclone); our $new_schema = dclone $schema; push @{ $new_schema->{classes} }, ( "CD::Compilation" => { # CD sub-class with an author per track bases => [ qw(CD) ], }, "CD::Compilation::Song" => { bases => [ qw(CD::Song) ], fields => { ref => { artist => { class => "CD::Artist" }, }, }, }, ); # munge all the table names $new_schema->{normalize} = sub { my $class_name = shift; (my $table_name = $class_name) =~ s{::}{_}g; $table_name =~ s{^}{new_}; return $table_name; }; # normalisation isn't applied to manually configured names! $new_schema->{classes}[9]{fields}{set}{members}{table} = "new_artistgroup"; $new_schema->{control} = "new_Tangram"; sub AUTOLOAD { my ($func) = ($AUTOLOAD =~ m/.*::(.*)$/); return Tangram::Schema->new(${$func}) } 1; Tangram-2.12/t/musicstore/Prerequisites.pm0000644000175000017500000000021712605613635017376 0ustar samvsamv package Prerequisites; use lib "t"; use DBConfig; use TestNeeds qw(Test::More Class::Accessor::Assert Time::Piece); use MusicStore; 1; Tangram-2.12/t/musicstore/01-simple.t0000644000175000017500000001464712605613726016105 0ustar samvsamv# -*- perl -*- # test script for the Persistathon - set TANGRAM_TRACE=1 in the # environment for a nice log of what queries Tangram is running. use lib "t/musicstore"; use Prerequisites; use strict; use Test::More tests => 25; use Tangram::Storage; # various items that will "persist" between test blocks use vars qw($storage); my ($oid, $id, $r_cd, $r_artist, $band, $row, $join, $filter); # open a storage connection - this will be # Tangram::Relational->connect(), etc. $storage = DBConfig->dialect->connect(MusicStore->schema, DBConfig->cparm); { # 1. create a new database object of each type in the schema my ($cd, @songs, $band, @people); $band = CD::Band->new ({ name => "The Upbeats", popularity => "World Famous in New Zealand", cds => Set::Object->new ( $cd= CD->new({title => "The Upbeats", publishdate => iso('2004-04-01'), songs => [ @songs= CD::Song->new({name => "Hello"}), CD::Song->new({name => "Drizzle"}), CD::Song->new({name => "From the Deep"}), ], }), ), members => Set::Object->new ( @people = CD::Person->new({ name => "Jeremy Glenn" }), CD::Person->new({ name => "Dylan Jones" }), ), }); # stick it in $oid = $storage->insert($band); $id = $storage->export_object($band); ok($oid, "Inserted a band and associated objects"); # 2. print the object IDs if ( -t STDIN ) { #unless running in the harness... diag($_) foreach ("Band: ".$storage->export_object($band), "People: ".join(",", $storage->export_object(@people)), "CD storage ID: ".$storage->export_object($cd), "Songs: ".join(",", $storage->export_object(@songs))); } # put in some extra data for fun require 'insert_extra_data.pl'; } # objects should now be gone, as they have fallen out of scope is($CD::c, 0, "no objects leaked"); { # two loading strategies - one is the `exported' object, where you # pass in a type and an ID - note that any superclass is OK (the # import is polymorphic) $band = $storage->import_object("CD::Artist", $id); isa_ok($band, "CD::Band", "Band loaded by exported ID"); # the second is to import by oid, which includes the class ID... my $band2 = $storage->load($oid); isa_ok($band2, "CD::Band", "Band loaded by OID"); is($band, $band2, "Seperate loads returned same object"); } is($CD::c, 1, "no objects leaked"); { # 4. fetch an artist record by name (exact match) $r_artist = $storage->remote("CD::Artist"); my @artists = $storage->select ( $r_artist, $r_artist->{name} eq "The Upbeats" ); is(@artists, 1, "got an object out"); # extra demonstration - is it the same object as $band ? is($artists[0], $band, "selects return cached objects"); } is($CD::c, 1, "no objects leaked"); { # 5. fetch an artist record with a search term (globbing / LIKE / # etc) my (@artists) = $storage->select ( $r_artist, $r_artist->{name}->upper()->like(uc("%beat%")), ); is(@artists, 2, "got two artists matching %beat%"); ok(Set::Object->new(@artists)->includes($band), "select still returns cached objects"); undef($band); } is($CD::c, 0, "no objects leaked"); { # 6. fetch CD records by matching on a partial *artist's* name, # using a cursor if possible. $r_cd = $storage->remote("CD"); $join = ($r_cd->{artist} == $r_artist); my $query = $r_artist->{name}->upper()->like(uc("%beat%")); my $filter = $join & $query; my $cursor = $storage->cursor ( $r_cd, $filter ); my @cds; while ( my $cd = $cursor->current ) { push @cds, $cd; $cursor->next; } is(@cds, 3, "Found three CDs by artists matching %beat%"); # if we just wanted the count: my ($count) = $storage->count($filter); is($count, 3, "Can do simple COUNT() queries - compat"); $count = $storage->count($r_cd, $filter); is($count, 3, "Can do simple COUNT() queries - proper"); # maybe some other aggregation type queries: ($row) = $storage->select ( undef, # no object filter => $filter, retrieve => [ $r_cd->{publishdate}->min(), $r_cd->{publishdate}->max(), ], ); # this could probably be considered a design caveat $_ = $storage->from_dbms("date", $_) foreach @$row; } is($CD::c, 0, "no objects leaked"); { is_deeply($row, [ '1999-10-26T00:00:00', '2004-04-01T00:00:00' ], "aggregation type queries"); # 7. fetch unique CD records by matching on a partial artist's # *or* partial CD name, using a cursor if possible. my $query = ( $r_artist->{name}->upper()->like(uc("%beat%")) | $r_cd->{title}->upper()->like(uc("%beat%")) ); my $filter = $join & $query; my $cursor = $storage->cursor ( $r_cd, $filter ); my @cds=(); while ( my $cd = $cursor->current ) { diag ("found cd = " .$cd->title.", artist = ".$cd->artist->name); push @cds, $cd; $cursor->next; } is(@cds, 4, "Found four CDs by CD or artist name matching %beat%"); } is($CD::c, 0, "no objects leaked"); { #use YAML; #local($Tangram::TRACE) = \*STDERR; #local($Tangram::DEBUG_LEVEL) = 3; # 8. update a record or two my ($pfloyd) = $storage->select ( $r_artist, $r_artist->{name} eq "Pink Floyd" ); my $cd; $pfloyd->cds->insert ($cd= CD->new({ title => "The Dark Side of The Moon", publishdate => iso("2004-04-06"), songs => [ map { CD::Song->new({ name => $_ }) } "Speak To Me/Breathe", "On The Run", "Time", "The Great Gig in the Sky", "Money", "Us And Them", "Any Colour You Like", "Brain Damage", "Eclipse", ], }) ); $pfloyd->popularity("legendary"); $storage->update($pfloyd); ok($storage->id($cd), "Automatically added a new Set member"); } is($CD::c, 0, "no objects leaked"); { my ($pfloyd) = $storage->select ( $r_artist, $r_artist->{name} eq "Pink Floyd" ); is($pfloyd->popularity, "legendary", "saved an object property"); } is($CD::c, 0, "no objects leaked"); { # 9. delete some records my (@gonners) = $storage->select ($r_artist, $r_artist->{popularity} eq "one hit wonder"); $storage->erase(@gonners); ok(!$storage->id($gonners[0]), "No longer part of storage"); } is($CD::c, 0, "no objects leaked"); our %formats; BEGIN { %formats = ( 4 => "%Y", 10 => "%Y-%m-%d", 19 => "%Y-%m-%dT%H:%M:%S", ); } sub iso { my $str = shift; Time::Piece->strptime($str, $formats{length($str)}); } Tangram-2.12/t/musicstore/zz-retreat.t0000644000175000017500000000100312605613635016462 0ustar samvsamv#!/usr/bin/perl -w use strict; use lib "t"; use lib "t/musicstore"; use Prerequisites; use Test::More tests => 2; BEGIN { use_ok "MusicStore"; }; local $/; SKIP: { my $dbh = DBI->connect( $DBConfig::cs, $DBConfig::user, $DBConfig::passwd ) or skip "could not connect to database", 1; $DBConfig::dialect->retreat(MusicStore->schema, $dbh); $DBConfig::dialect->retreat(MusicStore->new_schema, $dbh); pass("deploy completed without raising errors"); $dbh->disconnect; } Tangram-2.12/t/musicstore/00-deploy.t0000644000175000017500000000123312605613635016071 0ustar samvsamv#!/usr/bin/perl -w use strict; use lib "t"; use lib "t/musicstore"; use Prerequisites; use Test::More tests => 2; BEGIN { use_ok "MusicStore"; }; local $/; SKIP: { my $dbh = DBI->connect( $DBConfig::cs, $DBConfig::user, $DBConfig::passwd ) or skip "could not connect to database", 1; do { local $dbh->{PrintError}; local $dbh->{RaiseError}; $DBConfig::dialect->retreat(MusicStore->schema, $dbh); $DBConfig::dialect->retreat(MusicStore->new_schema, $dbh); }; $dbh->{RaiseError} = 1; $DBConfig::dialect->deploy(MusicStore->schema, $dbh); pass("deploy completed without raising errors"); $dbh->disconnect; } Tangram-2.12/t/README.pod0000644000175000017500000000577412605613635013455 0ustar samvsamv =head1 NAME t/ - worked examples for Tangram, some based on real world applications =head1 CONTENTS =over =item F Originally the only test suite for Tangram, this test suite balooned with extra relationship types and features until it became quite unmanagable! =item F an example schema modeled after Request Tracker, a popular e-mail helpdesk application. See F for documentation. =item F an example schema modeled after the test database for Class::DBI, the schema for which is available at L. Sections from this test suite are included in L. =item F This schema is for problems that relate to I