t/relationship/info.t

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