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) = @_; |
8 | die "No such column ${col}" unless $self->_columns->{$col}; |
9 | eval "require $f_class"; |
10 | my ($pri, $too_many) = keys %{ $f_class->_primaries }; |
11 | die "has_a only works with a single primary key; ${f_class} has more" |
12 | if $too_many; |
13 | $self->add_relationship($col, $f_class, |
14 | { "foreign.${pri}" => "self.${col}" }, |
15 | { _type => 'has_a' } ); |
16 | $self->delete_accessor($col); |
17 | $self->mk_group_accessors('has_a' => $col); |
18 | return 1; |
19 | } |
20 | |
21 | sub get_has_a { |
22 | my ($self, $rel) = @_; |
23 | #warn $rel; |
24 | #warn join(', ', %{$self->{_column_data}}); |
25 | return $self->{_relationship_data}{$rel} |
26 | if $self->{_relationship_data}{$rel}; |
27 | return undef unless $self->get_column($rel); |
28 | #my ($pri) = (keys %{$self->_relationships->{$rel}{class}->_primaries})[0]; |
29 | return $self->{_relationship_data}{$rel} = |
30 | ($self->search_related($rel, {}, {}))[0] |
31 | || do { |
32 | my $f_class = $self->_relationships->{$rel}{class}; |
33 | my ($pri) = keys %{$f_class->_primaries}; |
34 | $f_class->new({ $pri => $self->get_column($rel) }); }; |
35 | } |
36 | |
37 | sub set_has_a { |
38 | my ($self, $rel, @rest) = @_; |
39 | my $ret = $self->store_has_a($rel, @rest); |
40 | $self->{_dirty_columns}{$rel} = 1; |
41 | return $ret; |
42 | } |
43 | |
44 | sub store_has_a { |
45 | my ($self, $rel, $obj) = @_; |
9bc6db13 |
46 | unless (ref $obj) { |
47 | delete $self->{_relationship_data}{$rel}; |
48 | return $self->store_column($rel, $obj); |
49 | } |
b8e1e21f |
50 | my $rel_obj = $self->_relationships->{$rel}; |
51 | die "Can't set $rel: object $obj is not of class ".$rel_obj->{class} |
52 | unless $obj->isa($rel_obj->{class}); |
53 | $self->{_relationship_data}{$rel} = $obj; |
9bc6db13 |
54 | #warn "Storing $obj: ".($obj->_ident_values)[0]; |
55 | $self->store_column($rel, ($obj->_ident_values)[0]); |
b8e1e21f |
56 | return $obj; |
57 | } |
58 | |
59 | sub new { |
60 | my ($class, $attrs, @rest) = @_; |
61 | my %hasa; |
62 | foreach my $key (keys %$attrs) { |
63 | my $rt = $class->_relationships->{$key}{attrs}{_type}; |
64 | next unless $rt && $rt eq 'has_a' && ref $attrs->{$key}; |
65 | $hasa{$key} = delete $attrs->{$key}; |
66 | } |
67 | my $new = $class->NEXT::ACTUAL::new($attrs, @rest); |
68 | foreach my $key (keys %hasa) { |
69 | $new->store_has_a($key, $hasa{$key}); |
70 | } |
71 | return $new; |
72 | } |
73 | |
74 | sub _cond_value { |
75 | my ($self, $attrs, $key, $value) = @_; |
76 | if ( my $rel_obj = $self->_relationships->{$key} ) { |
77 | my $rel_type = $rel_obj->{attrs}{_type} || ''; |
78 | if ($rel_type eq 'has_a' && ref $value) { |
79 | die "Object $value is not of class ".$rel_obj->{class} |
80 | unless $value->isa($rel_obj->{class}); |
81 | $value = ($value->_ident_values)[0]; |
82 | #warn $value; |
83 | } |
84 | } |
85 | return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value); |
86 | } |
87 | |
88 | 1; |