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