1package # hide from PAUSE 2 DBIx::Class::CDBICompat::Relationships; 3 4use strict; 5use warnings; 6use Sub::Name (); 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 - Emulate has_a(), has_many(), might_have() and meta_info() 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 { 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 { 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 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 54 $rel_info = { 55 class => $f_class 56 }; 57 } 58 else { 59 $self->belongs_to($col, $f_class); 60 $rel_info = $self->result_source_instance->relationship_info($col); 61 } 62 63 $rel_info->{args} = \%args; 64 65 $self->_extend_meta( 66 has_a => $col, 67 $rel_info 68 ); 69 70 return 1; 71} 72 73sub _mk_inflated_column_accessor { 74 my($class, $col) = @_; 75 76 return $class->mk_group_accessors('inflated_column' => $col); 77} 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 ||= {}; 91 my $cascade = delete $args->{cascade} || ''; 92 if (delete $args->{no_cascade_delete} || $cascade eq 'None') { 93 $args->{cascade_delete} = 0; 94 } 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 } 101 102 if( !$f_key and !@f_method ) { 103 $class->ensure_class_loaded($f_class); 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 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 116 $class->_extend_meta( 117 has_many => $rel, 118 $rel_info 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 my $name = join '::', $class, $rel; 126 *$name = Sub::Name::subname $name, 127 sub { 128 my $rs = shift->search_related($rel => @_); 129 $rs->{attrs}{record_filter} = $post_proc; 130 return (wantarray ? $rs->all : $rs); 131 }; 132 return 1; 133 } 134 135} 136 137 138sub might_have { 139 my ($class, $rel, $f_class, @columns) = @_; 140 141 my $ret; 142 if (ref $columns[0] || !defined $columns[0]) { 143 $ret = $class->next::method($rel, $f_class, @columns); 144 } else { 145 $ret = $class->next::method($rel, $f_class, undef, 146 { proxy => \@columns }); 147 } 148 149 my $rel_info = $class->result_source_instance->relationship_info($rel); 150 $rel_info->{args}{import} = \@columns; 151 152 $class->_extend_meta( 153 might_have => $rel, 154 $rel_info 155 ); 156 157 return $ret; 158} 159 160 161sub _extend_meta { 162 my ($class, $type, $rel, $val) = @_; 163 my %hash = %{ Clone::clone($class->__meta_info || {}) }; 164 165 $val->{self_class} = $class; 166 $val->{type} = $type; 167 $val->{accessor} = $rel; 168 169 $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val); 170 $class->__meta_info(\%hash); 171} 172 173 174sub meta_info { 175 my ($class, $type, $rel) = @_; 176 my $meta = $class->__meta_info; 177 return $meta unless $type; 178 179 my $type_meta = $meta->{$type}; 180 return $type_meta unless $rel; 181 return $type_meta->{$rel}; 182} 183 184 185sub search { 186 my $self = shift; 187 my $attrs = {}; 188 if (@_ > 1 && ref $_[$#_] eq 'HASH') { 189 $attrs = { %{ pop(@_) } }; 190 } 191 my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift) 192 : {@_}) 193 : undef()); 194 if (ref $where eq 'HASH') { 195 foreach my $key (keys %$where) { # has_a deflation hack 196 $where->{$key} = ''.$where->{$key} 197 if eval { $where->{$key}->isa('DBIx::Class') }; 198 } 199 } 200 $self->next::method($where, $attrs); 201} 202 2031; 204