X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRelationship%2FBase.pm;h=64536797cf62dd09294b6895f542d40d7951161d;hb=09d2e66a5d5558ef9a19dc2ec510d5dafd2fb7d8;hp=158740390d9e526de0d45c131b49e8cdede061c4;hpb=a2bd379666d729133d65c85dc775627937084b18;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 1587403..6453679 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -6,8 +6,11 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; -use Try::Tiny; -use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; +use DBIx::Class::_Util qw( + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR + fail_on_internal_call +); +use DBIx::Class::Carp; use namespace::clean; =head1 NAME @@ -499,107 +502,104 @@ this instance (like in the case of C relationships). =cut sub related_resultset { - my $self = shift; + $_[0]->throw_exception( + '$result->related_resultset() no longer accepts extra search arguments, ' + . 'you need to switch to ...->related_resultset($relname)->search_rs(...) ' + . 'instead (it was never documented and more importantly could never work ' + . 'reliably due to the heavy caching involved)' + ) if @_ > 2; - $self->throw_exception("Can't call *_related as class methods") - unless ref $self; + $_[0]->throw_exception("Can't call *_related as class methods") + unless ref $_[0]; - my $rel = shift; + return $_[0]->{related_resultsets}{$_[1]} + if defined $_[0]->{related_resultsets}{$_[1]}; - return $self->{related_resultsets}{$rel} - if defined $self->{related_resultsets}{$rel}; + my ($self, $rel) = @_; - return $self->{related_resultsets}{$rel} = do { + my $rsrc = $self->result_source; - my $rsrc = $self->result_source; + my $rel_info = $rsrc->relationship_info($rel) + or $self->throw_exception( "No such relationship '$rel'" ); - my $rel_info = $rsrc->relationship_info($rel) - or $self->throw_exception( "No such relationship '$rel'" ); + my $relcond_is_freeform = ref $rel_info->{cond} eq 'CODE'; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); - $attrs = { %{$rel_info->{attrs} || {}}, %$attrs }; + my $jfc = $rsrc->_resolve_relationship_condition( - $self->throw_exception( "Invalid query: @_" ) - if (@_ > 1 && (@_ % 2 == 1)); - my $query = ((@_ > 1) ? {@_} : shift); + rel_name => $rel, + self_result_object => $self, - # condition resolution may fail if an incomplete master-object prefetch - # is encountered - that is ok during prefetch construction (not yet in_storage) - my ($cond, $is_crosstable) = try { - $rsrc->_resolve_condition( $rel_info->{cond}, $rel, $self, $rel ) - } - catch { - $self->throw_exception ($_) if $self->in_storage; - UNRESOLVABLE_CONDITION; # RV, no return() + # an extra sanity check guard + require_join_free_condition => ! $relcond_is_freeform, + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + + # this may look weird, but remember that we are making a resultset + # out of an existing object, with the new source being at the head + # of the FROM chain. Having a 'me' alias is nothing but expected there + foreign_alias => 'me', + + )->{join_free_condition}; + + my $rel_rset; + + if ( + ! $jfc + and + $relcond_is_freeform + ) { + + # A WHOREIFFIC hack to reinvoke the entire condition resolution + # with the correct alias. Another way of doing this involves a + # lot of state passing around, and the @_ positions are already + # mapped out, making this crap a less icky option. + # + # The point of this exercise is to retain the spirit of the original + # $obj->search_related($rel) where the resulting rset will have the + # root alias as 'me', instead of $rel (as opposed to invoking + # $rs->search_related) + + # make the fake 'me' rel + local $rsrc->{_relationships}{me} = { + %{ $rsrc->{_relationships}{$rel} }, + _original_name => $rel, }; - # keep in mind that the following if() block is part of a do{} - no return()s!!! - if ($is_crosstable and ref $rel_info->{cond} eq 'CODE') { - - # A WHOREIFFIC hack to reinvoke the entire condition resolution - # with the correct alias. Another way of doing this involves a - # lot of state passing around, and the @_ positions are already - # mapped out, making this crap a less icky option. - # - # The point of this exercise is to retain the spirit of the original - # $obj->search_related($rel) where the resulting rset will have the - # root alias as 'me', instead of $rel (as opposed to invoking - # $rs->search_related) - - # make the fake 'me' rel - local $rsrc->{_relationships}{me} = { - %{ $rsrc->{_relationships}{$rel} }, - _original_name => $rel, - }; - - my $obj_table_alias = lc($rsrc->source_name) . '__row'; - $obj_table_alias =~ s/\W+/_/g; + my $obj_table_alias = lc($rsrc->source_name) . '__row'; + $obj_table_alias =~ s/\W+/_/g; - $rsrc->resultset->search( - $self->ident_condition($obj_table_alias), - { alias => $obj_table_alias }, - )->search_related('me', $query, $attrs) - } - else { - # FIXME - this conditional doesn't seem correct - got to figure out - # at some point what it does. Also the entire UNRESOLVABLE_CONDITION - # business seems shady - we could simply not query *at all* - if ($cond eq UNRESOLVABLE_CONDITION) { - my $reverse = $rsrc->reverse_relationship_info($rel); - foreach my $rev_rel (keys %$reverse) { - if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') { - weaken($attrs->{related_objects}{$rev_rel}[0] = $self); - } else { - weaken($attrs->{related_objects}{$rev_rel} = $self); - } - } - } - elsif (ref $cond eq 'ARRAY') { - $cond = [ map { - if (ref $_ eq 'HASH') { - my $hash; - foreach my $key (keys %$_) { - my $newkey = $key !~ /\./ ? "me.$key" : $key; - $hash->{$newkey} = $_->{$key}; - } - $hash; - } else { - $_; - } - } @$cond ]; - } - elsif (ref $cond eq 'HASH') { - foreach my $key (grep { ! /\./ } keys %$cond) { - $cond->{"me.$key"} = delete $cond->{$key}; + $rel_rset = $rsrc->resultset->search( + $self->ident_condition($obj_table_alias), + { alias => $obj_table_alias }, + )->related_resultset('me')->search(undef, $rel_info->{attrs}) + } + else { + + # FIXME - this conditional doesn't seem correct - got to figure out + # at some point what it does. Also the entire UNRESOLVABLE_CONDITION + # business seems shady - we could simply not query *at all* + my $attrs; + if ( $jfc eq UNRESOLVABLE_CONDITION ) { + $attrs = { %{$rel_info->{attrs}} }; + my $reverse = $rsrc->reverse_relationship_info($rel); + foreach my $rev_rel (keys %$reverse) { + if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') { + weaken($attrs->{related_objects}{$rev_rel}[0] = $self); + } else { + weaken($attrs->{related_objects}{$rev_rel} = $self); } } - - $query = ($query ? { '-and' => [ $cond, $query ] } : $cond); - $rsrc->related_source($rel)->resultset->search( - $query, $attrs - ); } - }; + + $rel_rset = $rsrc->related_source($rel)->resultset->search( + $jfc, + $attrs || $rel_info->{attrs}, + ); + } + + $self->{related_resultsets}{$rel} = $rel_rset; } =head2 search_related @@ -620,8 +620,9 @@ See L for more information. =cut -sub search_related { - return shift->related_resultset(shift)->search(@_); +sub search_related :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search(@_); } =head2 search_related_rs @@ -631,8 +632,9 @@ it guarantees a resultset, even in list context. =cut -sub search_related_rs { - return shift->related_resultset(shift)->search_rs(@_); +sub search_related_rs :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search_rs(@_) } =head2 count_related @@ -650,8 +652,9 @@ current result or where conditions. =cut -sub count_related { - shift->search_related(@_)->count; +sub count_related :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search_rs(@_)->count; } =head2 new_related @@ -674,12 +677,15 @@ your storage until you call L on it. sub new_related { my ($self, $rel, $data) = @_; - return $self->search_related($rel)->new_result( $self->result_source->_resolve_relationship_condition ( + $self->related_resultset($rel)->new_result( $self->result_source->_resolve_relationship_condition ( infer_values_based_on => $data, rel_name => $rel, self_result_object => $self, - foreign_alias => $rel, - self_alias => 'me', + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + )->{inferred_values} ); } @@ -726,9 +732,10 @@ See L for details. =cut -sub find_related { +sub find_related :DBIC_method_is_indirect_sugar { #my ($self, $rel, @args) = @_; - return shift->search_related(shift)->find(@_); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + return shift->related_resultset(shift)->find(@_); } =head2 find_or_new_related @@ -748,8 +755,9 @@ for details. sub find_or_new_related { my $self = shift; - my $obj = $self->find_related(@_); - return defined $obj ? $obj : $self->new_related(@_); + my $rel = shift; + my $obj = $self->related_resultset($rel)->find(@_); + return defined $obj ? $obj : $self->related_resultset($rel)->new_result(@_); } =head2 find_or_create_related @@ -769,8 +777,9 @@ L for details. sub find_or_create_related { my $self = shift; - my $obj = $self->find_related(@_); - return (defined($obj) ? $obj : $self->create_related(@_)); + my $rel = shift; + my $obj = $self->related_resultset($rel)->find(@_); + return (defined($obj) ? $obj : $self->create_related( $rel => @_ )); } =head2 update_or_create_related @@ -788,8 +797,9 @@ L for details. =cut -sub update_or_create_related { +sub update_or_create_related :DBIC_method_is_indirect_sugar { #my ($self, $rel, @args) = @_; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->related_resultset(shift)->update_or_create(@_); } @@ -825,9 +835,39 @@ sub set_from_related { $self->set_columns( $self->result_source->_resolve_relationship_condition ( infer_values_based_on => {}, rel_name => $rel, - foreign_values => $f_obj, - foreign_alias => $rel, - self_alias => 'me', + foreign_values => ( + # maintain crazy set_from_related interface + # + ( ! defined $f_obj ) ? +{} + : ( ! defined blessed $f_obj ) ? $f_obj + : do { + + my $f_result_class = $self->result_source->related_source($rel)->result_class; + + unless( $f_obj->isa($f_result_class) ) { + + $self->throw_exception( + 'Object supplied to set_from_related() must inherit from ' + . "'$DBIx::Class::ResultSource::__expected_result_class_isa'" + ) unless $f_obj->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + ); + + carp_unique( + 'Object supplied to set_from_related() usually should inherit from ' + . "the related ResultClass ('$f_result_class'), perhaps you've made " + . 'a mistake?' + ); + } + + +{ $f_obj->get_columns }; + } + ), + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + )->{inferred_values} ); return 1; @@ -877,8 +917,9 @@ And returns the result of that. sub delete_related { my $self = shift; - my $obj = $self->search_related(@_)->delete; - delete $self->{related_resultsets}->{$_[0]}; + my $rel = shift; + my $obj = $self->related_resultset($rel)->search_rs(@_)->delete; + delete $self->{related_resultsets}->{$rel}; return $obj; }