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