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 ||= {}; |
73 | if (delete $args->{no_cascade_delete}) { |
74 | $args->{cascade_delete} = 0; |
75 | } |
76 | |
77 | if( !$f_key and !@f_method ) { |
78 | my $f_source = $f_class->result_source_instance; |
79 | ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class } |
80 | $f_source->relationships; |
81 | } |
82 | |
83 | $class->next::method($rel, $f_class, $f_key, $args); |
84 | |
85 | $class->_extend_meta( |
86 | has_many => $rel, |
87 | $class->result_source_instance->relationship_info($rel) |
88 | ); |
89 | |
90 | if (@f_method) { |
91 | no strict 'refs'; |
92 | no warnings 'redefine'; |
93 | my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; }; |
94 | *{"${class}::${rel}"} = |
95 | sub { |
96 | my $rs = shift->search_related($rel => @_); |
97 | $rs->{attrs}{record_filter} = $post_proc; |
98 | return (wantarray ? $rs->all : $rs); |
99 | }; |
100 | return 1; |
101 | } |
102 | |
103 | } |
104 | |
105 | |
106 | sub might_have { |
107 | my ($class, $rel, $f_class, @columns) = @_; |
108 | |
109 | my $ret; |
110 | if (ref $columns[0] || !defined $columns[0]) { |
111 | $ret = $class->next::method($rel, $f_class, @columns); |
112 | } else { |
113 | $ret = $class->next::method($rel, $f_class, undef, |
114 | { proxy => \@columns }); |
115 | } |
116 | |
117 | $class->_extend_meta( |
118 | might_have => $rel, |
119 | $class->result_source_instance->relationship_info($rel) |
120 | ); |
121 | |
122 | return $ret; |
123 | } |
124 | |
125 | |
126 | sub _extend_meta { |
127 | my ($class, $type, $rel, $val) = @_; |
128 | my %hash = %{ Clone::clone($class->__meta_info || {}) }; |
129 | |
130 | $val->{self_class} = $class; |
131 | $val->{type} = $type; |
132 | $val->{accessor} = $rel; |
133 | |
134 | $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val); |
135 | $class->__meta_info(\%hash); |
136 | } |
137 | |
aa11d765 |
138 | |
a9c8094b |
139 | sub meta_info { |
140 | my ($class, $type, $rel) = @_; |
141 | my $meta = $class->__meta_info; |
142 | return $meta unless $type; |
143 | |
144 | my $type_meta = $meta->{$type}; |
145 | return $type_meta unless $rel; |
146 | return $type_meta->{$rel}; |
147 | } |
148 | |
149 | |
150 | sub search { |
151 | my $self = shift; |
152 | my $attrs = {}; |
153 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
154 | $attrs = { %{ pop(@_) } }; |
155 | } |
156 | my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift) |
157 | : {@_}) |
158 | : undef()); |
159 | if (ref $where eq 'HASH') { |
160 | foreach my $key (keys %$where) { # has_a deflation hack |
161 | $where->{$key} = ''.$where->{$key} |
162 | if eval { $where->{$key}->isa('DBIx::Class') }; |
163 | } |
164 | } |
165 | $self->next::method($where, $attrs); |
166 | } |
167 | |
168 | 1; |