Commit | Line | Data |
1e0daa97 |
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; |