X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=d23497c9ec72dfe5957fba1d77569707244d3393;hb=f4a8b21ef21bb85228f0ee10e1abbad2116c702b;hp=565410e83b5ba641799293323250b41b67b823e1;hpb=bcf127a59c3cdddc0a609b73fa64fb66cce61976;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 565410e..d23497c 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -1496,6 +1496,37 @@ sub reverse_relationship_info { return $ret; } +sub _join_condition_to_hashref { + my ($self, $dq) = @_; + my (@q, %found) = ($dq); + Q: while (my $n = shift @q) { + if (is_Operator($n)) { + if (($n->{operator}{Perl}||'') =~ /^(?:==|eq)$/) { + my ($l, $r) = @{$n->{args}}; + if ( + is_Identifier($l) and @{$l->{elements}} == 2 + and is_Identifier($r) and @{$r->{elements}} == 2 + ) { + ($l, $r) = ($r, $l) if $l->{elements}[0] eq 'self'; + if ( + $l->{elements}[0] eq 'foreign' + and $r->{elements}[0] eq 'self' + ) { + $found{$l->{elements}[1]} = $r->{elements}[1]; + next Q; + } + } + } elsif (($n->{operator}{Perl}||'') eq 'and') { + push @q, @{$n->{args}}; + next Q; + } + } + # didn't match as 'and' or 'foreign.x = self.y', can't handle this + return undef; + } + return keys %found ? \%found : undef; +} + # all this does is removes the foreign/self prefix from a condition sub __strip_relcond { if (ref($_[1]) eq 'HASH') { @@ -1505,33 +1536,7 @@ sub __strip_relcond { keys %{$_[1]} }; } elsif (blessed($_[1]) and $_[1]->isa('Data::Query::ExprBuilder')) { - my (@q, %found) = ($_[1]->{expr}); - Q: while (my $n = shift @q) { - if (is_Operator($n)) { - if (($n->{operator}{Perl}||'') =~ /^(?:==|eq)$/) { - my ($l, $r) = @{$n->{args}}; - if ( - is_Identifier($l) and @{$l->{elements}} == 2 - and is_Identifier($r) and @{$r->{elements}} == 2 - ) { - ($l, $r) = ($r, $l) if $l->{elements}[0] eq 'self'; - if ( - $l->{elements}[0] eq 'foreign' - and $r->{elements}[0] eq 'self' - ) { - $found{$l->{elements}[1]} = $r->{elements}[1]; - next Q; - } - } - } elsif (($n->{operator}{Perl}||'') eq 'and') { - push @q, @{$n->{args}}; - next Q; - } - } - # didn't match as 'and' or 'foreign.x = self.y', can't handle this - return undef; - } - return \%found; + return $_[0]->_join_condition_to_hashref($_[1]->{expr}); } return undef; } @@ -1542,37 +1547,61 @@ sub _extract_fixed_values_for { return +{ map { is_Value($fixed->{$_}) ? ($_ => $fixed->{$_}{value}) - : () + : (is_Literal($fixed->{$_}) ? ($_ => \($fixed->{$_})) : ()) } keys %$fixed }; } sub _extract_fixed_conditions_for { my ($self, $dq, $alias) = @_; my (@q, %found) = ($dq); - while (my $n = shift @q) { - if (is_Operator($n)) { - if (($n->{operator}{Perl}||'') =~ /^(?:==|eq)$/) { - my ($l, $r) = @{$n->{args}}; - if ( - is_Identifier($r) and @{$r->{elements}} == 2 - and (!$alias or $r->{elements}[0] eq $alias) - ) { - ($l, $r) = ($r, $l); - } - if ( - is_Identifier($l) and @{$l->{elements}} == 2 - and (!$alias or $l->{elements}[0] eq $alias) - ) { - $found{$l->{elements}[1]} = $r; - } elsif (($n->{operator}{Perl}||'') eq 'and') { - push @q, @{$n->{args}}; - } + foreach my $n ($self->_extract_top_level_conditions($dq)) { + if ( + is_Operator($n) + and ( + ($n->{operator}{Perl}||'') =~ /^(?:==|eq)$/ + or ($n->{operator}{'SQL.Naive'}||'') eq '=' + ) + ) { + my ($l, $r) = @{$n->{args}}; + if ( + is_Identifier($r) and ( + !$alias + or (@{$r->{elements}} == 2 + and $r->{elements}[0] eq $alias) + ) + ) { + ($l, $r) = ($r, $l); + } + if ( + is_Identifier($l) and ( + !$alias + or (@{$l->{elements}} == 2 + and $l->{elements}[0] eq $alias) + ) + ) { + $found{$alias ? $l->{elements}[1] : join('.',@{$l->{elements}})} = $r; } } } return \%found; } +sub _extract_top_level_conditions { + my ($self, $dq) = @_; + my (@q, @found) = ($dq); + while (my $n = shift @q) { + if ( + is_Operator($n) + and ($n->{operator}{Perl}||$n->{operator}{'SQL.Naive'}||'') =~ /^and$/i + ) { + push @q, @{$n->{args}}; + } else { + push @found, $n; + } + } + return @found; +} + sub compare_relationship_keys { carp 'compare_relationship_keys is a private method, stop calling it'; my $self = shift; @@ -1715,10 +1744,19 @@ sub _pk_depends_on { if exists ($relinfo->{attrs}{is_foreign_key_constraint}); my $cond = $relinfo->{cond}; - return 0 unless ref($cond) eq 'HASH'; - - # map { foreign.foo => 'self.bar' } to { bar => 'foo' } - my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond }; + my $keyhash = do { + if (ref($cond) eq 'HASH') { + + # map { foreign.foo => 'self.bar' } to { bar => 'foo' } + +{ map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond }; + } elsif (ref($cond) eq 'REF' and ref($$cond) eq 'HASH') { + my $fixed = $self->_join_condition_to_hashref($$cond); + return 0 unless $fixed; + +{ reverse %$fixed }; + } else { + return 0; + } + }; # assume anything that references our PK probably is dependent on us # rather than vice versa, unless the far side is (a) defined or (b) @@ -1744,7 +1782,9 @@ sub resolve_condition { $self->_resolve_condition (@_); } -our $UNRESOLVABLE_CONDITION = \ '1 = 0'; +our $UNRESOLVABLE_CONDITION = \Literal(SQL => '1 = 0'); + +${$UNRESOLVABLE_CONDITION}->{'DBIx::Class::ResultSource.UNRESOLVABLE'} = 1; # Resolves the passed condition to a concrete query fragment and a flag # indicating whether this is a cross-table condition. Also an optional @@ -1882,30 +1922,70 @@ sub _resolve_condition { return wantarray ? (\@ret, $crosstable) : \@ret; } elsif (blessed($cond) and $cond->isa('Data::Query::ExprBuilder')) { - my %cross; + my (%cross, $unresolvable); my $as = blessed($for) ? 'me' : $as; - my $mapped = map_dq_tree { - if (is_Identifier and @{$_->{elements}} == 2) { - foreach my $check ([ foreign => $as ], [ self => $for ]) { - my ($ident, $thing) = @$check; - if ($_->{elements}[0] eq $ident) { - if ($thing and !ref($thing)) { - $cross{$thing} = 1; - return \Identifier($thing, $_->{elements}[1]); - } elsif (!defined($thing)) { - return \perl_scalar_value(undef); - } elsif ((ref($thing)||'') eq 'HASH') { - return \perl_scalar_value($thing->{$_->{elements}[1]}); - } elsif (blessed($thing)) { - return \perl_scalar_value($thing->get_column($_->{elements}[1])); - } else { - die "I have no idea what ${thing} is supposed to be"; + my %action = map { + my ($ident, $thing, $other) = @$_; + ($ident => do { + if ($thing and !ref($thing)) { + sub { + $cross{$thing} = 1; + return \Identifier($thing, $_[0]->{elements}[1]); + } + } elsif (!defined($thing)) { + sub { + \perl_scalar_value( + undef, + $_[1] ? join('.', $other, $_[1]->{elements}[1]) : () + ); + } + } elsif ((ref($thing)||'') eq 'HASH') { + sub { + \perl_scalar_value( + $thing->{$_->{elements}[1]}, + $_[1] ? join('.', $other, $_[1]->{elements}[1]) : () + ); + } + } elsif (blessed($thing)) { + sub { + unless ($thing->has_column_loaded($_[0]->{elements}[1])) { + if ($thing->in_storage) { + $self->throw_exception(sprintf + "Unable to resolve relationship '%s' from object %s: column '%s' not " + . 'loaded from storage (or not passed to new() prior to insert()). You ' + . 'probably need to call ->discard_changes to get the server-side defaults ' + . 'from the database.', + $as, + $thing, + $_[0]->{elements}[1] + ); + } + $unresolvable = 1; } + return \perl_scalar_value( + $thing->get_column($_[0]->{elements}[1]), + $_[1] ? join('.', $other, $_[1]->{elements}[1]) : () + ); } + } else { + die "I have no idea what ${thing} is supposed to be"; } + }) + } ([ foreign => $as, $for ], [ self => $for, $as ]); + my %seen; + my $mapped = map_dq_tree { + if (is_Operator and @{$_->{args}} == 2) { + @seen{@{$_->{args}}} = reverse @{$_->{args}}; + } + if ( + is_Identifier and @{$_->{elements}} == 2 + and my $act = $action{$_->{elements}[0]} + ) { + return $act->($_, $seen{$_}); } return $_; } $cond->{expr}; + return $UNRESOLVABLE_CONDITION if $unresolvable; return (wantarray ? (\$mapped, (keys %cross == 2)) : \$mapped); } else {