use strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 40); } INIT { use lib 't/testlib'; use Film; use Director; Film->CONSTRUCT; Director->CONSTRUCT; @YA::Film::ISA = 'Film'; } ok my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste"; ok my $pj = $btaste->Director, "Bad taste has a director"; ok !ref($pj), ' ... which is not an object'; ok(Film->has_a('director' => 'Director'), "Link Director table"); ok( Director->create({ Name => 'Peter Jackson', Birthday => -300000000, IsInsane => 1 } ), 'create Director' ); { ok $btaste = Film->retrieve('Bad Taste'), "Reretrieve Bad Taste"; ok $pj = $btaste->Director, "Bad taste now hasa() director"; isa_ok $pj => 'Director'; { no warnings 'redefine'; local *Ima::DBI::st::execute = sub { ::fail("Shouldn't need to query db"); }; is $pj->id, 'Peter Jackson', 'ID already stored'; } ok $pj->IsInsane, "But we know he's insane"; } # Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him. my $sj = Director->create({ Name => 'Skippy Jackson', Birthday => (-300000000 + 60), IsInsane => 1, }); { eval { $btaste->Director($btaste) }; like $@, qr/is not a Director/, "Can't set film as director"; is $btaste->Director->id, $pj->id, "PJ still the director"; # drop from cache so that next retrieve() is from db $btaste->remove_from_object_index; } { # Still inflated after update my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste->Director, "Director"; $btaste->numexplodingsheep(17); $btaste->update; isa_ok $btaste->Director, "Director"; $btaste->Director('Someone Else'); $btaste->update; isa_ok $btaste->Director, "Director"; is $btaste->Director->id, "Someone Else", "Can change director"; } is $sj->id, 'Skippy Jackson', 'Create new director - Skippy'; Film->has_a('codirector' => 'Director'); { eval { $btaste->CoDirector("Skippy Jackson") }; is $@, "", "Auto inflates"; isa_ok $btaste->CoDirector, "Director"; is $btaste->CoDirector->id, $sj->id, "To skippy"; } $btaste->CoDirector($sj); $btaste->update; is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed'); is( $btaste->Director->Name, 'Peter Jackson', "Didnt interfere with each other" ); { # Inheriting hasa my $btaste = YA::Film->retrieve('Bad Taste'); is(ref($btaste->Director), 'Director', 'inheriting hasa()'); is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()'); is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly'); } { $sj = Director->retrieve('Skippy Jackson'); $pj = Director->retrieve('Peter Jackson'); my $fail; eval { $fail = YA::Film->create({ Title => 'Tastes Bad', Director => $sj, codirector => $btaste, Rating => 'R', NumExplodingSheep => 23 }); }; ok $@, "Can't have film as codirector: $@"; is $fail, undef, "We didn't get anything"; my $tastes_bad = YA::Film->create({ Title => 'Tastes Bad', Director => $sj, codirector => $pj, Rating => 'R', NumExplodingSheep => 23 }); is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director'); is( $tastes_bad->_director_accessor->Name, 'Skippy Jackson', 'director_accessor' ); is($tastes_bad->codirector->Name, 'Peter Jackson', 'codirector'); is( $tastes_bad->_codirector_accessor->Name, 'Peter Jackson', 'codirector_accessor' ); } { { YA::Film->add_relationship_type(has_a => "YA::HasA"); package YA::HasA; use base 'Class::DBI::Relationship::HasA'; sub _inflator { my $self = shift; my $col = $self->accessor; my $super = $self->SUPER::_inflator($col); return $super unless $col eq $self->class->find_column('Director'); return sub { my $self = shift; $self->_attribute_store($col, 'Ghostly Peter') if $self->_attribute_exists($col) and not defined $self->_attrs($col); return &$super($self); }; } } { package Rating; sub new { my ($class, $mpaa, @details) = @_; bless { MPAA => $mpaa, WHY => "@details" }, $class; } sub mpaa { shift->{MPAA}; } sub why { shift->{WHY}; } } local *Director::mapme = sub { my ($class, $val) = @_; $val =~ s/Skippy/Peter/; $val; }; no warnings 'once'; local *Director::sanity_check = sub { $_[0]->IsInsane ? undef: $_[0] }; YA::Film->has_a( director => 'Director', inflate => 'mapme', deflate => 'sanity_check' ); YA::Film->has_a( rating => 'Rating', inflate => sub { my ($val, $parent) = @_; my $sheep = $parent->find_column('NumexplodingSheep'); if ($parent->_attrs($sheep) || 0 > 20) { return new Rating 'NC17', 'Graphic ovine violence'; } else { return new Rating $val, 'Just because'; } }, deflate => sub { shift->mpaa; }); my $tbad = YA::Film->retrieve('Tastes Bad'); isa_ok $tbad->Director, 'Director'; is $tbad->Director->Name, 'Peter Jackson', 'Director shuffle'; $tbad->Director('Skippy Jackson'); $tbad->update; is $tbad->Director, 'Ghostly Peter', 'Sanity checked'; isa_ok $tbad->Rating, 'Rating'; is $tbad->Rating->mpaa, 'NC17', 'Rating bumped'; $tbad->Rating(new Rating 'NS17', 'Shaken sheep'); no warnings 'redefine'; local *Director::mapme = sub { my ($class, $obj) = @_; $obj->isa('Film') ? $obj->Director : $obj; }; $pj->IsInsane(0); $pj->update; # Hush warnings ok $tbad->Director($btaste), 'Cross-class mapping'; is $tbad->Director, 'Peter Jackson', 'Yields PJ'; $tbad->update; $tbad = Film->retrieve('Tastes Bad'); ok !ref($tbad->Rating), 'Unmagical rating'; is $tbad->Rating, 'NS17', 'but prior change stuck'; }