1package Class::DBI::Relationship::HasMany; 2 3use strict; 4use warnings; 5 6use base 'Class::DBI::Relationship'; 7 8sub remap_arguments { 9 my ($proto, $class, $accessor, $f_class, $f_key, $args) = @_; 10 11 return $class->_croak($class->name . " needs an accessor name") 12 unless $accessor; 13 return $class->_croak($class->name . " needs a foreign class") 14 unless $f_class; 15 16 { 17 no strict 'refs'; 18 defined &{"$class\::$accessor"} 19 and return $class->_carp("$accessor method already exists in $class\n"); 20 } 21 22 my @f_method = (); 23 if (ref $f_class eq "ARRAY") { 24 ($f_class, @f_method) = @$f_class; 25 } 26 $class->_require_class($f_class); 27 28 if (ref $f_key eq "HASH") { # didn't supply f_key, this is really $args 29 $args = $f_key; 30 $f_key = ""; 31 } 32 33 $f_key ||= do { 34 my $meta = $f_class->meta_info('has_a'); 35 my ($col) = grep $meta->{$_}->foreign_class eq $class, keys %$meta; 36 $col || $class->table_alias; 37 }; 38 39 if (ref $f_key eq "ARRAY") { 40 return $class->_croak("Multi-column foreign keys not supported") 41 if @$f_key > 1; 42 $f_key = $f_key->[0]; 43 } 44 45 $args ||= {}; 46 $args->{mapping} = \@f_method; 47 $args->{foreign_key} = $f_key; 48 $args->{order_by} ||= $args->{sort}; # deprecated 0.96 49 warn "sort argument to has_many deprecated in favour of order_by" 50 if $args->{sort}; # deprecated 0.96 51 52 return ($class, $accessor, $f_class, $args); 53} 54 55sub _set_up_class_data { 56 my $self = shift; 57 $self->class->_extend_class_data( 58 __hasa_list => $self->foreign_class => $self->args->{foreign_key}); 59 $self->SUPER::_set_up_class_data; 60} 61 62sub triggers { 63 my $self = shift; 64 if ($self->args->{no_cascade_delete}) { # old undocumented way 65 warn "no_cascade_delete deprecated in favour of cascade => None"; 66 return; 67 } 68 my $strategy = $self->args->{cascade} || "Delete"; 69 $strategy = "Class::DBI::Cascade::$strategy" unless $strategy =~ /::/; 70 71 $self->foreign_class->_require_class($strategy); 72 $strategy->can('cascade') 73 or return $self->_croak("$strategy is not a valid Cascade Strategy"); 74 my $strat_obj = $strategy->new($self); 75 return (before_delete => sub { $strat_obj->cascade(@_) }); 76} 77 78sub methods { 79 my $self = shift; 80 my $accessor = $self->accessor; 81 return ( 82 $accessor => $self->_has_many_method, 83 "add_to_$accessor" => $self->_method_add_to, 84 ); 85} 86 87sub _method_add_to { 88 my $rel = shift; 89 my $accessor = $rel->accessor; 90 return sub { 91 my ($self, $data) = @_; 92 my $class = ref $self 93 or return $self->_croak("add_to_$accessor called as class method"); 94 return $self->_croak("add_to_$accessor needs data") 95 unless ref $data eq "HASH"; 96 97 my $meta = $class->meta_info($rel->name => $accessor); 98 my ($f_class, $f_key, $args) = 99 ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args); 100 $data->{$f_key} = $self->id; 101 102 # See if has_many constraints were defined and auto fill them 103 if (defined $args->{constraint} && ref $args->{constraint} eq 'HASH') { 104 while (my ($k, $v) = each %{ $args->{constraint} }) { 105 $self->_croak( 106 "Can't add_to_$accessor with $k = $data->{$k} (must be $v)") 107 if defined($data->{$k}) && $data->{$k} ne $v; 108 $data->{$k} = $v; 109 } 110 } 111 112 $f_class->insert($data); 113 }; 114} 115 116sub _has_many_method { 117 my $self = shift; 118 my $run_search = $self->_hm_run_search; 119 my @mapping = @{ $self->args->{mapping} } or return $run_search; 120 return sub { 121 return $run_search->(@_)->set_mapping_method(@mapping) 122 unless wantarray; 123 my @ret = $run_search->(@_); 124 foreach my $meth (@mapping) { @ret = map $_->$meth(), @ret } 125 return @ret; 126 } 127} 128 129sub _hm_run_search { 130 my $rel = shift; 131 my ($class, $accessor) = ($rel->class, $rel->accessor); 132 return sub { 133 my ($self, @search_args) = @_; 134 @search_args = %{ $search_args[0] } if ref $search_args[0] eq "HASH"; 135 my $meta = $class->meta_info($rel->name => $accessor); 136 my ($f_class, $f_key, $args) = 137 ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args); 138 if (ref $self) { # For $artist->cds 139 unshift @search_args, %{ $args->{constraint} } 140 if defined($args->{constraint}) && ref $args->{constraint} eq 'HASH'; 141 unshift @search_args, ($f_key => $self->id); 142 push @search_args, { order_by => $args->{order_by} } 143 if defined $args->{order_by}; 144 return $f_class->search(@search_args); 145 } else { # For Artist->cds 146 # Cross-table join as class method 147 # This stuff is highly experimental and will probably change beyond 148 # recognition. Use at your own risk... 149 my %kv = @search_args; 150 my $query = Class::DBI::Query->new({ owner => $f_class }); 151 $query->kings($class, $f_class); 152 $query->add_restriction(sprintf "%s.%s = %s.%s", 153 $f_class->table_alias, $f_key, $class->table_alias, 154 $class->primary_column); 155 $query->add_restriction("$_ = ?") for keys %kv; 156 my $sth = $query->run(values %kv); 157 return $f_class->sth_to_objects($sth); 158 } 159 }; 160} 161 1621; 163