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