Commit | Line | Data |
a9c8094b |
1 | package # hide from PAUSE |
2 | DBIx::Class::CDBICompat::Relationships; |
3 | |
4 | use strict; |
5 | use warnings; |
8d73fcd4 |
6 | use base 'Class::Data::Inheritable'; |
a9c8094b |
7 | |
8 | use Clone; |
9 | use DBIx::Class::CDBICompat::Relationship; |
dff89602 |
10 | use Scalar::Util 'blessed'; |
8d73fcd4 |
11 | use DBIx::Class::_Util qw(quote_sub perlstring); |
a9c8094b |
12 | |
13 | __PACKAGE__->mk_classdata('__meta_info' => {}); |
14 | |
15 | |
16 | =head1 NAME |
17 | |
b24d86a1 |
18 | DBIx::Class::CDBICompat::Relationships - Emulate has_a(), has_many(), might_have() and meta_info() |
a9c8094b |
19 | |
20 | =head1 DESCRIPTION |
21 | |
22 | Emulate C<has_a>, C<has_many>, C<might_have> and C<meta_info>. |
23 | |
24 | =cut |
25 | |
26 | sub has_a { |
c79bd6e9 |
27 | my($self, $col, @rest) = @_; |
d4daee7b |
28 | |
c79bd6e9 |
29 | $self->_declare_has_a($col, @rest); |
30 | $self->_mk_inflated_column_accessor($col); |
d4daee7b |
31 | |
c79bd6e9 |
32 | return 1; |
33 | } |
34 | |
35 | |
36 | sub _declare_has_a { |
a9c8094b |
37 | my ($self, $col, $f_class, %args) = @_; |
c79bd6e9 |
38 | $self->throw_exception( "No such column ${col}" ) |
39 | unless $self->has_column($col); |
a9c8094b |
40 | $self->ensure_class_loaded($f_class); |
d4daee7b |
41 | |
1097f5e4 |
42 | my $rel_info; |
a9c8094b |
43 | |
2040ad73 |
44 | # Class::DBI allows Non database has_a with implicit deflate and inflate |
45 | # Hopefully the following will catch Non-database tables. |
46 | if( !$f_class->isa('DBIx::Class::Row') and !$f_class->isa('Class::DBI::Row') ) { |
47 | $args{'inflate'} ||= sub { $f_class->new(shift) }; # implicit inflate by calling new |
48 | $args{'deflate'} ||= sub { shift() . '' }; # implicit deflate by stringification |
49 | } |
50 | |
a9c8094b |
51 | if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a |
52 | if (!ref $args{'inflate'}) { |
53 | my $meth = $args{'inflate'}; |
54 | $args{'inflate'} = sub { $f_class->$meth(shift); }; |
55 | } |
56 | if (!ref $args{'deflate'}) { |
57 | my $meth = $args{'deflate'}; |
58 | $args{'deflate'} = sub { shift->$meth; }; |
59 | } |
60 | $self->inflate_column($col, \%args); |
d4daee7b |
61 | |
1097f5e4 |
62 | $rel_info = { |
a9c8094b |
63 | class => $f_class |
64 | }; |
65 | } |
66 | else { |
67 | $self->belongs_to($col, $f_class); |
1097f5e4 |
68 | $rel_info = $self->result_source_instance->relationship_info($col); |
a9c8094b |
69 | } |
d4daee7b |
70 | |
1097f5e4 |
71 | $rel_info->{args} = \%args; |
d4daee7b |
72 | |
a9c8094b |
73 | $self->_extend_meta( |
74 | has_a => $col, |
1097f5e4 |
75 | $rel_info |
a9c8094b |
76 | ); |
c79bd6e9 |
77 | |
a9c8094b |
78 | return 1; |
79 | } |
80 | |
c79bd6e9 |
81 | sub _mk_inflated_column_accessor { |
82 | my($class, $col) = @_; |
d4daee7b |
83 | |
c79bd6e9 |
84 | return $class->mk_group_accessors('inflated_column' => $col); |
85 | } |
a9c8094b |
86 | |
87 | sub has_many { |
88 | my ($class, $rel, $f_class, $f_key, $args) = @_; |
89 | |
90 | my @f_method; |
91 | |
92 | if (ref $f_class eq 'ARRAY') { |
93 | ($f_class, @f_method) = @$f_class; |
94 | } |
95 | |
96 | if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; }; |
97 | |
98 | $args ||= {}; |
deff792e |
99 | my $cascade = delete $args->{cascade} || ''; |
100 | if (delete $args->{no_cascade_delete} || $cascade eq 'None') { |
a9c8094b |
101 | $args->{cascade_delete} = 0; |
102 | } |
deff792e |
103 | elsif( $cascade eq 'Delete' ) { |
104 | $args->{cascade_delete} = 1; |
105 | } |
106 | elsif( length $cascade ) { |
107 | warn "Unemulated cascade option '$cascade' in $class->has_many($rel => $f_class)"; |
108 | } |
a9c8094b |
109 | |
110 | if( !$f_key and !@f_method ) { |
4656f62f |
111 | $class->ensure_class_loaded($f_class); |
a9c8094b |
112 | my $f_source = $f_class->result_source_instance; |
113 | ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class } |
114 | $f_source->relationships; |
115 | } |
116 | |
117 | $class->next::method($rel, $f_class, $f_key, $args); |
118 | |
1097f5e4 |
119 | my $rel_info = $class->result_source_instance->relationship_info($rel); |
120 | $args->{mapping} = \@f_method; |
121 | $args->{foreign_key} = $f_key; |
122 | $rel_info->{args} = $args; |
123 | |
a9c8094b |
124 | $class->_extend_meta( |
125 | has_many => $rel, |
1097f5e4 |
126 | $rel_info |
a9c8094b |
127 | ); |
128 | |
129 | if (@f_method) { |
8d73fcd4 |
130 | quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }; |
131 | my $rs = shift->search_related( %s => @_); |
132 | $rs->{attrs}{record_filter} = $rf; |
133 | return (wantarray ? $rs->all : $rs); |
134 | EOC |
135 | |
a9c8094b |
136 | return 1; |
137 | } |
a9c8094b |
138 | } |
139 | |
140 | |
141 | sub might_have { |
142 | my ($class, $rel, $f_class, @columns) = @_; |
d4daee7b |
143 | |
a9c8094b |
144 | my $ret; |
145 | if (ref $columns[0] || !defined $columns[0]) { |
146 | $ret = $class->next::method($rel, $f_class, @columns); |
147 | } else { |
148 | $ret = $class->next::method($rel, $f_class, undef, |
149 | { proxy => \@columns }); |
150 | } |
1097f5e4 |
151 | |
152 | my $rel_info = $class->result_source_instance->relationship_info($rel); |
153 | $rel_info->{args}{import} = \@columns; |
154 | |
a9c8094b |
155 | $class->_extend_meta( |
156 | might_have => $rel, |
1097f5e4 |
157 | $rel_info |
a9c8094b |
158 | ); |
d4daee7b |
159 | |
a9c8094b |
160 | return $ret; |
161 | } |
162 | |
163 | |
164 | sub _extend_meta { |
165 | my ($class, $type, $rel, $val) = @_; |
1c30a2e4 |
166 | |
167 | ### Explicitly not using the deep cloner as Clone exhibits specific behavior |
168 | ### wrt CODE references - it simply passes them as-is to the new structure |
169 | ### (without deparse/eval cycles). There likely is code that relies on this |
170 | ### so we just let sleeping dogs lie. |
171 | my $hash = Clone::clone($class->__meta_info || {}); |
a9c8094b |
172 | |
173 | $val->{self_class} = $class; |
174 | $val->{type} = $type; |
175 | $val->{accessor} = $rel; |
176 | |
1c30a2e4 |
177 | $hash->{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val); |
178 | $class->__meta_info($hash); |
a9c8094b |
179 | } |
180 | |
aa11d765 |
181 | |
a9c8094b |
182 | sub meta_info { |
183 | my ($class, $type, $rel) = @_; |
184 | my $meta = $class->__meta_info; |
185 | return $meta unless $type; |
186 | |
187 | my $type_meta = $meta->{$type}; |
188 | return $type_meta unless $rel; |
189 | return $type_meta->{$rel}; |
190 | } |
191 | |
192 | |
193 | sub search { |
194 | my $self = shift; |
195 | my $attrs = {}; |
196 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
197 | $attrs = { %{ pop(@_) } }; |
198 | } |
199 | my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift) |
200 | : {@_}) |
201 | : undef()); |
202 | if (ref $where eq 'HASH') { |
203 | foreach my $key (keys %$where) { # has_a deflation hack |
dff89602 |
204 | $where->{$key} = ''.$where->{$key} if ( |
205 | defined blessed $where->{$key} |
206 | and |
207 | $where->{$key}->isa('DBIx::Class') |
208 | ); |
a9c8094b |
209 | } |
210 | } |
211 | $self->next::method($where, $attrs); |
212 | } |
213 | |
ee333775 |
214 | sub new_related { |
215 | return shift->search_related(shift)->new_result(shift); |
216 | } |
217 | |
a2bd3796 |
218 | =head1 FURTHER QUESTIONS? |
219 | |
220 | Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. |
221 | |
222 | =head1 COPYRIGHT AND LICENSE |
223 | |
224 | This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> |
225 | by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can |
226 | redistribute it and/or modify it under the same terms as the |
227 | L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. |
228 | |
229 | =cut |
230 | |
a9c8094b |
231 | 1; |