Commit | Line | Data |
b8e1e21f |
1 | package DBIx::Class::CDBICompat::HasMany; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | sub has_many { |
7 | my ($class, $rel, $f_class, $f_key, $args) = @_; |
95a70f01 |
8 | |
9 | my $self_key; |
10 | |
11 | if (ref $f_class eq 'ARRAY') { |
12 | ($f_class, $self_key) = @$f_class; |
13 | } |
14 | |
15 | if (!$self_key || $self_key eq 'id') { |
16 | my ($pri, $too_many) = keys %{ $class->_primaries }; |
78bab9ca |
17 | $class->throw( "has_many only works with a single primary key; ${class} has more" ) |
95a70f01 |
18 | if $too_many; |
19 | $self_key = $pri; |
20 | } |
21 | |
b8e1e21f |
22 | eval "require $f_class"; |
95a70f01 |
23 | |
b8e1e21f |
24 | if (ref $f_key eq 'HASH') { $args = $f_key; undef $f_key; }; |
95a70f01 |
25 | |
604d9f38 |
26 | #unless ($f_key) { Not selective enough. Removed pending fix. |
27 | # ($f_rel) = grep { $_->{class} && $_->{class} eq $class } |
28 | # $f_class->_relationships; |
29 | #} |
95a70f01 |
30 | |
9bc6db13 |
31 | unless ($f_key) { |
32 | #warn join(', ', %{ $f_class->_columns }); |
33 | $class =~ /([^\:]+)$/; |
34 | #warn $1; |
35 | $f_key = lc $1 if $f_class->_columns->{lc $1}; |
36 | } |
95a70f01 |
37 | |
78bab9ca |
38 | $class->throw( "Unable to resolve foreign key for has_many from ${class} to ${f_class}" ) |
b8e1e21f |
39 | unless $f_key; |
78bab9ca |
40 | $class->throw( "No such column ${f_key} on foreign class ${f_class}" ) |
b8e1e21f |
41 | unless $f_class->_columns->{$f_key}; |
42 | $class->add_relationship($rel, $f_class, |
95a70f01 |
43 | { "foreign.${f_key}" => "self.${self_key}" }, |
b8e1e21f |
44 | { _type => 'has_many', %{$args || {}} } ); |
45 | { |
46 | no strict 'refs'; |
47 | *{"${class}::${rel}"} = sub { shift->search_related($rel, @_); }; |
48 | *{"${class}::add_to_${rel}"} = sub { shift->create_related($rel, @_); }; |
49 | } |
50 | return 1; |
51 | } |
52 | |
53 | sub delete { |
54 | my ($self, @rest) = @_; |
55 | return $self->NEXT::ACTUAL::delete(@rest) unless ref $self; |
56 | # I'm just ignoring this for class deletes because hell, the db should |
57 | # be handling this anyway. Assuming we have joins we probably actually |
58 | # *could* do them, but I'd rather not. |
59 | |
60 | my $ret = $self->NEXT::ACTUAL::delete(@rest); |
61 | |
62 | my %rels = %{ $self->_relationships }; |
63 | my @hm = grep { $rels{$_}{attrs}{_type} |
64 | && $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels; |
65 | foreach my $has_many (@hm) { |
95a70f01 |
66 | unless ($rels{$has_many}->{attrs}{no_cascade_delete}) { |
67 | $_->delete for $self->search_related($has_many) |
68 | } |
b8e1e21f |
69 | } |
70 | return $ret; |
71 | } |
72 | 1; |