File Coverage

blib/lib/DBIx/Class/CDBICompat/Relationships.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package # hide from PAUSE
2             DBIx::Class::CDBICompat::Relationships;
3              
4 2     2   1028 use strict;
  2         4  
  2         46  
5 2     2   10 use warnings;
  2         4  
  2         42  
6 2     2   8 use base 'Class::Data::Inheritable';
  2         3  
  2         176  
7              
8 2     2   279 use Clone;
  0            
  0            
9             use DBIx::Class::CDBICompat::Relationship;
10             use DBIx::Class::_Util qw(quote_sub perlstring);
11              
12             __PACKAGE__->mk_classdata('__meta_info' => {});
13              
14              
15             =head1 NAME
16              
17             DBIx::Class::CDBICompat::Relationships - Emulate has_a(), has_many(), might_have() and meta_info()
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, @rest) = @_;
27              
28             $self->_declare_has_a($col, @rest);
29             $self->_mk_inflated_column_accessor($col);
30              
31             return 1;
32             }
33              
34              
35             sub _declare_has_a {
36             my ($self, $col, $f_class, %args) = @_;
37             $self->throw_exception( "No such column ${col}" )
38             unless $self->has_column($col);
39             $self->ensure_class_loaded($f_class);
40              
41             my $rel_info;
42              
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              
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);
60              
61             $rel_info = {
62             class => $f_class
63             };
64             }
65             else {
66             $self->belongs_to($col, $f_class);
67             $rel_info = $self->result_source_instance->relationship_info($col);
68             }
69              
70             $rel_info->{args} = \%args;
71              
72             $self->_extend_meta(
73             has_a => $col,
74             $rel_info
75             );
76              
77             return 1;
78             }
79              
80             sub _mk_inflated_column_accessor {
81             my($class, $col) = @_;
82              
83             return $class->mk_group_accessors('inflated_column' => $col);
84             }
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 ||= {};
98             my $cascade = delete $args->{cascade} || '';
99             if (delete $args->{no_cascade_delete} || $cascade eq 'None') {
100             $args->{cascade_delete} = 0;
101             }
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             }
108              
109             if( !$f_key and !@f_method ) {
110             $class->ensure_class_loaded($f_class);
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              
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              
123             $class->_extend_meta(
124             has_many => $rel,
125             $rel_info
126             );
127              
128             if (@f_method) {
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              
135             return 1;
136             }
137             }
138              
139              
140             sub might_have {
141             my ($class, $rel, $f_class, @columns) = @_;
142              
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             }
150              
151             my $rel_info = $class->result_source_instance->relationship_info($rel);
152             $rel_info->{args}{import} = \@columns;
153              
154             $class->_extend_meta(
155             might_have => $rel,
156             $rel_info
157             );
158              
159             return $ret;
160             }
161              
162              
163             sub _extend_meta {
164             my ($class, $type, $rel, $val) = @_;
165             my %hash = %{ Clone::clone($class->__meta_info || {}) };
166              
167             $val->{self_class} = $class;
168             $val->{type} = $type;
169             $val->{accessor} = $rel;
170              
171             $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val);
172             $class->__meta_info(\%hash);
173             }
174              
175              
176             sub meta_info {
177             my ($class, $type, $rel) = @_;
178             my $meta = $class->__meta_info;
179             return $meta unless $type;
180              
181             my $type_meta = $meta->{$type};
182             return $type_meta unless $rel;
183             return $type_meta->{$rel};
184             }
185              
186              
187             sub search {
188             my $self = shift;
189             my $attrs = {};
190             if (@_ > 1 && ref $_[$#_] eq 'HASH') {
191             $attrs = { %{ pop(@_) } };
192             }
193             my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
194             : {@_})
195             : undef());
196             if (ref $where eq 'HASH') {
197             foreach my $key (keys %$where) { # has_a deflation hack
198             $where->{$key} = ''.$where->{$key}
199             if eval { $where->{$key}->isa('DBIx::Class') };
200             }
201             }
202             $self->next::method($where, $attrs);
203             }
204              
205             sub new_related {
206             return shift->search_related(shift)->new_result(shift);
207             }
208              
209             =head1 FURTHER QUESTIONS?
210              
211             Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
212              
213             =head1 COPYRIGHT AND LICENSE
214              
215             This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
216             by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
217             redistribute it and/or modify it under the same terms as the
218             L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
219              
220             =cut
221              
222             1;