t/relationship/info.t

   1 use strict;
   2 use warnings;
   3
   4 #
   5 # The test must be performed on non-registered result classes
   6 #
   7 {
   8   package DBICTest::Thing;
   9   use warnings;
  10   use strict;
  11   use base qw/DBIx::Class::Core/;
  12   __PACKAGE__->table('thing');
  13   __PACKAGE__->add_columns(qw/id ancestor_id/);
  14   __PACKAGE__->set_primary_key('id');
  15   __PACKAGE__->has_many(children => __PACKAGE__, 'id');
  16   __PACKAGE__->belongs_to(parent => __PACKAGE__, 'id', { join_type => 'left' } );
  17
  18   __PACKAGE__->has_many(subthings => 'DBICTest::SubThing', 'thing_id');
  19 }
  20
  21 {
  22   package DBICTest::SubThing;
  23   use warnings;
  24   use strict;
  25   use base qw/DBIx::Class::Core/;
  26   __PACKAGE__->table('subthing');
  27   __PACKAGE__->add_columns(qw/thing_id/);
  28   __PACKAGE__->belongs_to(thing => 'DBICTest::Thing', 'thing_id');
  29   __PACKAGE__->belongs_to(thing2 => 'DBICTest::Thing', 'thing_id', { join_type => 'left' } );
  30 }
  31
  32
  33 use Test::More;
  34 use lib qw(t/lib);
  35 use DBICTest;
  36
  37 my $schema = DBICTest->init_schema;
  38
  39 for my $without_schema (1,0) {
  40
  41   my ($t, $s) = $without_schema
  42     ? (qw/DBICTest::Thing DBICTest::SubThing/)
  43     : do {
  44       $schema->register_class(relinfo_thing => 'DBICTest::Thing');
  45       $schema->register_class(relinfo_subthing => 'DBICTest::SubThing');
  46
  47       map { $schema->source ($_) } qw/relinfo_thing relinfo_subthing/;
  48     }
  49   ;
  50
  51   is_deeply(
  52     [ sort $t->relationships ],
  53     [qw/ children parent subthings/],
  54     "Correct relationships on $t",
  55   );
  56
  57   is_deeply(
  58     [ sort $s->relationships ],
  59     [qw/ thing thing2 /],
  60     "Correct relationships on $s",
  61   );
  62
  63   is_deeply(
  64     _instance($s)->reverse_relationship_info('thing'),
  65     { subthings => $t->relationship_info('subthings') },
  66     'reverse_rel_info works cross-class belongs_to direction',
  67   );
  68   is_deeply(
  69     _instance($s)->reverse_relationship_info('thing2'),
  70     { subthings => $t->relationship_info('subthings') },
  71     'reverse_rel_info works cross-class belongs_to direction 2',
  72   );
  73
  74   is_deeply(
  75     _instance($t)->reverse_relationship_info('subthings'),
  76     { map { $_ => $s->relationship_info($_) } qw/thing thing2/ },
  77     'reverse_rel_info works cross-class has_many direction',
  78   );
  79
  80   is_deeply(
  81     _instance($t)->reverse_relationship_info('parent'),
  82     { children => $t->relationship_info('children') },
  83     'reverse_rel_info works in-class belongs_to direction',
  84   );
  85   is_deeply(
  86     _instance($t)->reverse_relationship_info('children'),
  87     { parent => $t->relationship_info('parent') },
  88     'reverse_rel_info works in-class has_many direction',
  89   );
  90 }
  91
  92 sub _instance {
  93   $_[0]->isa('DBIx::Class::ResultSource')
  94     ? $_[0]
  95     : $_[0]->result_source_instance
  96 }
  97
  98 done_testing;