--- /dev/null
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ if ($@) {
+ plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ next;
+ }
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 41);
+}
+
+use lib 't/cdbi/testlib';
+use Film;
+use Director;
+@YA::Film::ISA = 'Film';
+
+Film->create_test_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 qw(redefine once);
+ 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/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'
+ );
+}
+
+SKIP: {
+ skip "Non-standard CDBI relationships not supported by compat", 9;
+ {
+
+ 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';
+}
+
+{ # Broken has_a declaration
+ eval { Film->has_a(driector => "Director") };
+ like $@, qr/driector/, "Sensible error from has_a with incorrect column: $@";
+}
projects / dbsrgits/DBIx-Class.git / blobdiff