Move find_co_root into DBICTest::Util

[dbsrgits/DBIx-Class.git] / t / cdbi / 06-hasa.t

use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat';

use strict;
use warnings;

use Test::More;
use Test::Exception;
use DBIx::Class::_Util 'sigwarn_silencer';

@YA::Film::ISA = 'Film';

use lib 't/cdbi/testlib';
use Film;
use Director;

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'
);

$btaste = Film->retrieve('Bad Taste');

ok($pj = $btaste->Director, "Bad taste now has_a() director");
isa_ok($pj => 'Director');
is($pj->id, 'Peter Jackson', ' ... and is the correct director');

# 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,
  }
);

is($sj->id, 'Skippy Jackson', 'We have a new director');

Film->has_a(CoDirector => 'Director');

$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"
);

{ # Ensure search can take an object
  my @films = Film->search(Director => $pj);
  is @films, 1, "1 Film directed by $pj";
  is $films[0]->id, "Bad Taste", "Bad Taste";
}

inheriting_hasa();

{

  # Skippy directs a film and Peter helps!
  $sj = Director->retrieve('Skippy Jackson');
  $pj = Director->retrieve('Peter Jackson');

  fail_with_bad_object($sj, $btaste);
  taste_bad($sj,            $pj);
}

sub inheriting_hasa {
  my $btaste = YA::Film->retrieve('Bad Taste');
  is(ref($btaste->Director),   'Director', 'inheriting has_a()');
  is(ref($btaste->CoDirector), 'Director', 'inheriting has_a()');
  is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
}

sub taste_bad {
  my ($dir, $codir) = @_;
  my $tastes_bad = YA::Film->create(
    {
      Title             => 'Tastes Bad',
      Director          => $dir,
      CoDirector        => $codir,
      Rating            => 'R',
      NumExplodingSheep => 23
    }
  );
  is($tastes_bad->_Director_accessor, 'Skippy Jackson', 'Director_accessor');
  is($tastes_bad->Director->Name,   'Skippy Jackson', 'Director');
  is($tastes_bad->CoDirector->Name, 'Peter Jackson',  'CoDirector');
  is(
    $tastes_bad->_CoDirector_accessor,
    'Peter Jackson',
    'CoDirector_accessor'
  );
}

sub fail_with_bad_object {
  my ($dir, $codir) = @_;
  throws_ok {
    local $SIG{__WARN__} = sigwarn_silencer( qr/\Qusually should inherit from the related ResultClass ('Director')/ );
    YA::Film->create(
      {
        Title             => 'Tastes Bad',
        Director          => $dir,
        CoDirector        => $codir,
        Rating            => 'R',
        NumExplodingSheep => 23
      }
    );
  } qr/isn't a Director/;
}

package Foo;
use base 'CDBase';
__PACKAGE__->table('foo');
__PACKAGE__->columns('All' => qw/ id fav /);
# fav is a film
__PACKAGE__->db_Main->do( qq{
     CREATE TABLE foo (
       id        INTEGER,
       fav       VARCHAR(255)
     )
});


package Bar;
use base 'CDBase';
__PACKAGE__->table('bar');
__PACKAGE__->columns('All' => qw/ id fav /);
# fav is a foo
__PACKAGE__->db_Main->do( qq{
     CREATE TABLE bar (
       id        INTEGER,
       fav       INTEGER
     )
});

package main;
Foo->has_a("fav" => "Film");
Bar->has_a("fav" => "Foo");
my $foo = Foo->create({ id => 6, fav => 'Bad Taste' });
my $bar = Bar->create({ id => 2, fav => 6 });
isa_ok($bar->fav, "Foo");
isa_ok($foo->fav, "Film");

{
  my $foo;
  Foo->add_trigger(after_create => sub { $foo = shift->fav });
  my $gwh = Foo->create({ id => 93, fav => 'Good Will Hunting' });
  isa_ok $foo, "Film", "Object in after_create trigger";
}

done_testing;