1package Class::DBI::Relationship::HasA; 2 3use strict; 4use warnings; 5 6use base 'Class::DBI::Relationship'; 7 8sub remap_arguments { 9 my ($proto, $class, $want_col, $a_class, %meths) = @_; 10 $class->_invalid_object_method("has_a") if ref $class; 11 my $column = $class->find_column($want_col) 12 or return $class->_croak("Column $want_col does not exist in $class"); 13 $class->_croak("$class $column needs an associated class") unless $a_class; 14 return ($class, $column, $a_class, \%meths); 15} 16 17sub triggers { 18 my $self = shift; 19 $self->class->_require_class($self->foreign_class); 20 my $column = $self->accessor; 21 return ( 22 select => $self->_inflator, 23 24 # after_create => $self->_inflator, # see t/6 25 "after_set_$column" => $self->_inflator, 26 deflate_for_create => $self->_deflator(1), 27 deflate_for_update => $self->_deflator, 28 ); 29} 30 31sub _inflator { 32 my $rel = shift; 33 my $col = $rel->accessor; 34 return sub { 35 my $self = shift; 36 defined(my $value = $self->_attrs($col)) or return; 37 my $meta = $self->meta_info($rel->name => $col); 38 my ($a_class, %meths) = ($meta->foreign_class, %{ $meta->args }); 39 40 return if ref $value and $value->isa($a_class); 41 my $inflator; 42 43 my $get_new_value = sub { 44 my ($inflator, $value, $want_class, $obj) = @_; 45 my $new_value = 46 (ref $inflator eq 'CODE') 47 ? $inflator->($value, $obj) 48 : $want_class->$inflator($value); 49 return $new_value; 50 }; 51 52 # If we have a custom inflate ... 53 if (exists $meths{'inflate'}) { 54 $value = $get_new_value->($meths{'inflate'}, $value, $a_class, $self); 55 return $self->_attribute_store($col, $value) 56 if ref $value 57 and $value->isa($a_class); 58 $self->_croak("Inflate method didn't inflate right") if ref $value; 59 } 60 61 return $self->_croak("Can't inflate $col to $a_class using '$value': " 62 . ref($value) 63 . " is not a $a_class") 64 if ref $value; 65 66 $inflator = $a_class->isa('Class::DBI') ? "_simple_bless" : "new"; 67 $value = $get_new_value->($inflator, $value, $a_class); 68 69 return $self->_attribute_store($col, $value) 70 if ref $value 71 and $value->isa($a_class); 72 73 # use ref as $obj may be overloaded and appear 'false' 74 return $self->_croak( 75 "Can't inflate $col to $a_class " . "via $inflator using '$value'") 76 unless ref $value; 77 }; 78} 79 80sub _deflator { 81 my ($self, $always) = @_; 82 my $col = $self->accessor; 83 return sub { 84 my $self = shift; 85 return unless $self->_attribute_exists($col); 86 $self->_attribute_store($col => $self->_deflated_column($col)) 87 if ($always or $self->{__Changed}->{$col}); 88 }; 89} 90 91sub _set_up_class_data { 92 my $self = shift; 93 $self->class->_extend_class_data(__hasa_rels => $self->accessor => 94 [ $self->foreign_class, %{ $self->args } ]); 95 $self->SUPER::_set_up_class_data; 96} 97 981; 99