1 package DBIx::Class::CDBICompat::HasA;
7 my ($self, $col, $f_class) = @_;
8 $self->throw( "No such column ${col}" ) unless $self->_columns->{$col};
9 eval "require $f_class";
10 my ($pri, $too_many) = keys %{ $f_class->_primaries };
11 $self->throw( "has_a only works with a single primary key; ${f_class} has more" )
13 $self->add_relationship($col, $f_class,
14 { "foreign.${pri}" => "self.${col}" },
15 { _type => 'has_a' } );
16 $self->mk_group_accessors('has_a' => $col);
21 my ($self, $rel) = @_;
23 #warn join(', ', %{$self->{_column_data}});
24 return $self->{_relationship_data}{$rel}
25 if $self->{_relationship_data}{$rel};
26 return undef unless $self->get_column($rel);
27 #my ($pri) = (keys %{$self->_relationships->{$rel}{class}->_primaries})[0];
28 return $self->{_relationship_data}{$rel} =
29 ($self->search_related($rel, {}, {}))[0]
31 my $f_class = $self->_relationships->{$rel}{class};
32 my ($pri) = keys %{$f_class->_primaries};
33 $f_class->new({ $pri => $self->get_column($rel) }); };
37 my ($self, $rel, @rest) = @_;
38 my $ret = $self->store_has_a($rel, @rest);
39 $self->{_dirty_columns}{$rel} = 1;
44 my ($self, $rel, $obj) = @_;
46 delete $self->{_relationship_data}{$rel};
47 return $self->store_column($rel, $obj);
49 my $rel_obj = $self->_relationships->{$rel};
50 $self->throw( "Can't set $rel: object $obj is not of class ".$rel_obj->{class} )
51 unless $obj->isa($rel_obj->{class});
52 $self->{_relationship_data}{$rel} = $obj;
53 #warn "Storing $obj: ".($obj->_ident_values)[0];
54 $self->store_column($rel, ($obj->_ident_values)[0]);
59 my ($class, $attrs, @rest) = @_;
61 foreach my $key (keys %$attrs) {
62 my $rt = $class->_relationships->{$key}{attrs}{_type};
63 next unless $rt && $rt eq 'has_a' && ref $attrs->{$key};
64 $hasa{$key} = delete $attrs->{$key};
66 my $new = $class->NEXT::ACTUAL::new($attrs, @rest);
67 foreach my $key (keys %hasa) {
68 $new->store_has_a($key, $hasa{$key});
74 my ($self, $attrs, $key, $value) = @_;
75 if ( my $rel_obj = $self->_relationships->{$key} ) {
76 my $rel_type = $rel_obj->{attrs}{_type} || '';
77 if ($rel_type eq 'has_a' && ref $value) {
78 $self->throw( "Object $value is not of class ".$rel_obj->{class} )
79 unless $value->isa($rel_obj->{class});
80 $value = ($value->_ident_values)[0];
84 return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value);