Commit | Line | Data |
b8e1e21f |
1 | package DBIx::Class::CDBICompat::HasA; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | sub has_a { |
7 | my ($self, $col, $f_class) = @_; |
78bab9ca |
8 | $self->throw( "No such column ${col}" ) unless $self->_columns->{$col}; |
b8e1e21f |
9 | eval "require $f_class"; |
10 | my ($pri, $too_many) = keys %{ $f_class->_primaries }; |
78bab9ca |
11 | $self->throw( "has_a only works with a single primary key; ${f_class} has more" ) |
b8e1e21f |
12 | if $too_many; |
13 | $self->add_relationship($col, $f_class, |
14 | { "foreign.${pri}" => "self.${col}" }, |
15 | { _type => 'has_a' } ); |
b8e1e21f |
16 | $self->mk_group_accessors('has_a' => $col); |
17 | return 1; |
18 | } |
19 | |
20 | sub get_has_a { |
21 | my ($self, $rel) = @_; |
22 | #warn $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] |
30 | || do { |
31 | my $f_class = $self->_relationships->{$rel}{class}; |
32 | my ($pri) = keys %{$f_class->_primaries}; |
33 | $f_class->new({ $pri => $self->get_column($rel) }); }; |
34 | } |
35 | |
36 | sub set_has_a { |
37 | my ($self, $rel, @rest) = @_; |
38 | my $ret = $self->store_has_a($rel, @rest); |
39 | $self->{_dirty_columns}{$rel} = 1; |
40 | return $ret; |
41 | } |
42 | |
43 | sub store_has_a { |
44 | my ($self, $rel, $obj) = @_; |
9bc6db13 |
45 | unless (ref $obj) { |
46 | delete $self->{_relationship_data}{$rel}; |
47 | return $self->store_column($rel, $obj); |
48 | } |
b8e1e21f |
49 | my $rel_obj = $self->_relationships->{$rel}; |
78bab9ca |
50 | $self->throw( "Can't set $rel: object $obj is not of class ".$rel_obj->{class} ) |
b8e1e21f |
51 | unless $obj->isa($rel_obj->{class}); |
52 | $self->{_relationship_data}{$rel} = $obj; |
9bc6db13 |
53 | #warn "Storing $obj: ".($obj->_ident_values)[0]; |
54 | $self->store_column($rel, ($obj->_ident_values)[0]); |
b8e1e21f |
55 | return $obj; |
56 | } |
57 | |
58 | sub new { |
59 | my ($class, $attrs, @rest) = @_; |
60 | my %hasa; |
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}; |
65 | } |
66 | my $new = $class->NEXT::ACTUAL::new($attrs, @rest); |
67 | foreach my $key (keys %hasa) { |
68 | $new->store_has_a($key, $hasa{$key}); |
69 | } |
70 | return $new; |
71 | } |
72 | |
73 | sub _cond_value { |
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) { |
78bab9ca |
78 | $self->throw( "Object $value is not of class ".$rel_obj->{class} ) |
b8e1e21f |
79 | unless $value->isa($rel_obj->{class}); |
80 | $value = ($value->_ident_values)[0]; |
81 | #warn $value; |
82 | } |
83 | } |
84 | return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value); |
85 | } |
86 | |
87 | 1; |