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