Commit | Line | Data |
a9c8094b |
1 | package # hide from PAUSE |
2 | DBIx::Class::CDBICompat::Relationships; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use base qw/Class::Data::Inheritable/; |
8 | |
9 | use Clone; |
10 | use DBIx::Class::CDBICompat::Relationship; |
11 | |
12 | __PACKAGE__->mk_classdata('__meta_info' => {}); |
13 | |
14 | |
15 | =head1 NAME |
16 | |
17 | DBIx::Class::CDBICompat::Relationships |
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 { |
26 | my ($self, $col, $f_class, %args) = @_; |
27 | $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col); |
28 | $self->ensure_class_loaded($f_class); |
29 | |
30 | my $rel; |
31 | |
32 | if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a |
33 | if (!ref $args{'inflate'}) { |
34 | my $meth = $args{'inflate'}; |
35 | $args{'inflate'} = sub { $f_class->$meth(shift); }; |
36 | } |
37 | if (!ref $args{'deflate'}) { |
38 | my $meth = $args{'deflate'}; |
39 | $args{'deflate'} = sub { shift->$meth; }; |
40 | } |
41 | $self->inflate_column($col, \%args); |
42 | |
43 | $rel = { |
44 | class => $f_class |
45 | }; |
46 | } |
47 | else { |
48 | $self->belongs_to($col, $f_class); |
49 | $rel = $self->result_source_instance->relationship_info($col); |
50 | } |
51 | |
52 | $self->_extend_meta( |
53 | has_a => $col, |
54 | $rel |
55 | ); |
56 | |
57 | return 1; |
58 | } |
59 | |
60 | |
61 | sub has_many { |
62 | my ($class, $rel, $f_class, $f_key, $args) = @_; |
63 | |
64 | my @f_method; |
65 | |
66 | if (ref $f_class eq 'ARRAY') { |
67 | ($f_class, @f_method) = @$f_class; |
68 | } |
69 | |
70 | if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; }; |
71 | |
72 | $args ||= {}; |
deff792e |
73 | my $cascade = delete $args->{cascade} || ''; |
74 | if (delete $args->{no_cascade_delete} || $cascade eq 'None') { |
a9c8094b |
75 | $args->{cascade_delete} = 0; |
76 | } |
deff792e |
77 | elsif( $cascade eq 'Delete' ) { |
78 | $args->{cascade_delete} = 1; |
79 | } |
80 | elsif( length $cascade ) { |
81 | warn "Unemulated cascade option '$cascade' in $class->has_many($rel => $f_class)"; |
82 | } |
a9c8094b |
83 | |
84 | if( !$f_key and !@f_method ) { |
4656f62f |
85 | $class->ensure_class_loaded($f_class); |
a9c8094b |
86 | my $f_source = $f_class->result_source_instance; |
87 | ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class } |
88 | $f_source->relationships; |
89 | } |
90 | |
91 | $class->next::method($rel, $f_class, $f_key, $args); |
92 | |
93 | $class->_extend_meta( |
94 | has_many => $rel, |
95 | $class->result_source_instance->relationship_info($rel) |
96 | ); |
97 | |
98 | if (@f_method) { |
99 | no strict 'refs'; |
100 | no warnings 'redefine'; |
101 | my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; }; |
102 | *{"${class}::${rel}"} = |
103 | sub { |
104 | my $rs = shift->search_related($rel => @_); |
105 | $rs->{attrs}{record_filter} = $post_proc; |
106 | return (wantarray ? $rs->all : $rs); |
107 | }; |
108 | return 1; |
109 | } |
110 | |
111 | } |
112 | |
113 | |
114 | sub might_have { |
115 | my ($class, $rel, $f_class, @columns) = @_; |
116 | |
117 | my $ret; |
118 | if (ref $columns[0] || !defined $columns[0]) { |
119 | $ret = $class->next::method($rel, $f_class, @columns); |
120 | } else { |
121 | $ret = $class->next::method($rel, $f_class, undef, |
122 | { proxy => \@columns }); |
123 | } |
124 | |
125 | $class->_extend_meta( |
126 | might_have => $rel, |
127 | $class->result_source_instance->relationship_info($rel) |
128 | ); |
129 | |
130 | return $ret; |
131 | } |
132 | |
133 | |
134 | sub _extend_meta { |
135 | my ($class, $type, $rel, $val) = @_; |
136 | my %hash = %{ Clone::clone($class->__meta_info || {}) }; |
137 | |
138 | $val->{self_class} = $class; |
139 | $val->{type} = $type; |
140 | $val->{accessor} = $rel; |
141 | |
142 | $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val); |
143 | $class->__meta_info(\%hash); |
144 | } |
145 | |
aa11d765 |
146 | |
a9c8094b |
147 | sub meta_info { |
148 | my ($class, $type, $rel) = @_; |
149 | my $meta = $class->__meta_info; |
150 | return $meta unless $type; |
151 | |
152 | my $type_meta = $meta->{$type}; |
153 | return $type_meta unless $rel; |
154 | return $type_meta->{$rel}; |
155 | } |
156 | |
157 | |
158 | sub search { |
159 | my $self = shift; |
160 | my $attrs = {}; |
161 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
162 | $attrs = { %{ pop(@_) } }; |
163 | } |
164 | my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift) |
165 | : {@_}) |
166 | : undef()); |
167 | if (ref $where eq 'HASH') { |
168 | foreach my $key (keys %$where) { # has_a deflation hack |
169 | $where->{$key} = ''.$where->{$key} |
170 | if eval { $where->{$key}->isa('DBIx::Class') }; |
171 | } |
172 | } |
173 | $self->next::method($where, $attrs); |
174 | } |
175 | |
176 | 1; |