X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=0d8bbf534001b1829ad57bb5fcb2b0a3d7848b79;hb=b4e9f590228d1d73d4089c2ec88372e683e17aeb;hp=780aaa9ff1315fae0b8642de6649695831e937a9;hpb=3fc16c9aedbb4d864b98fbe9ed8c5cfe540f1496;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index 780aaa9..0d8bbf5 100644
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -7,11 +7,10 @@ use DBIx::Class::ResultSet;
 use DBIx::Class::ResultSourceHandle;
 
 use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
 use Try::Tiny;
 use List::Util 'first';
-use Scalar::Util qw/weaken isweak/;
-use Storable qw/nfreeze thaw/;
+use Scalar::Util qw/blessed weaken isweak/;
 use namespace::clean;
 
 use base qw/DBIx::Class/;
@@ -428,7 +427,7 @@ sub columns {
   my $columns_info = $source->columns_info;
 
 Like L</column_info> but returns information for the requested columns. If
-the optional column-list arrayref is ommitted it returns info on all columns
+the optional column-list arrayref is omitted it returns info on all columns
 currently defined on the ResultSource via L</add_columns>.
 
 =cut
@@ -634,7 +633,7 @@ sub sequence {
   my ($self,$seq) = @_;
 
   my @pks = $self->primary_columns
-    or next;
+    or return;
 
   $_->{sequence} = $seq
     for values %{ $self->columns_info (\@pks) };
@@ -1327,56 +1326,74 @@ L</relationship_info>.
 
 sub reverse_relationship_info {
   my ($self, $rel) = @_;
-  my $rel_info = $self->relationship_info($rel);
+
+  my $rel_info = $self->relationship_info($rel)
+    or $self->throw_exception("No such relationship '$rel'");
+
   my $ret = {};
 
   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
 
-  my @cond = keys(%{$rel_info->{cond}});
-  my @refkeys = map {/^\w+\.(\w+)$/} @cond;
-  my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
+  my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
+
+  my $rsrc_schema_moniker = $self->source_name
+    if try { $self->schema };
 
-  # Get the related result source for this relationship
-  my $othertable = $self->related_source($rel);
+  # this may be a partial schema or something else equally esoteric
+  my $other_rsrc = try { $self->related_source($rel) }
+    or return $ret;
 
   # Get all the relationships for that source that related to this source
   # whose foreign column set are our self columns on $rel and whose self
-  # columns are our foreign columns on $rel.
-  my @otherrels = $othertable->relationships();
-  my $otherrelationship;
-  foreach my $otherrel (@otherrels) {
-    # this may be a partial schema with the related source not being
-    # available at all
-    my $back = try { $othertable->related_source($otherrel) } or next;
-
-    # did we get back to ourselves?
-    next unless $back->source_name eq $self->source_name;
-
-    my $otherrel_info = $othertable->relationship_info($otherrel);
-    my @othertestconds;
-
-    if (ref $otherrel_info->{cond} eq 'HASH') {
-      @othertestconds = ($otherrel_info->{cond});
-    }
-    elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
-      @othertestconds = @{$otherrel_info->{cond}};
+  # columns are our foreign columns on $rel
+  foreach my $other_rel ($other_rsrc->relationships) {
+
+    # only consider stuff that points back to us
+    # "us" here is tricky - if we are in a schema registration, we want
+    # to use the source_names, otherwise we will use the actual classes
+
+    # the schema may be partial
+    my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) }
+      or next;
+
+    if ($rsrc_schema_moniker and try { $roundtrip_rsrc->schema } ) {
+      next unless $rsrc_schema_moniker eq $roundtrip_rsrc->source_name;
     }
     else {
-      next;
+      next unless $self->result_class eq $roundtrip_rsrc->result_class;
     }
 
-    foreach my $othercond (@othertestconds) {
-      my @other_cond = keys(%$othercond);
-      my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
-      my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
-      next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
-               !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
-      $ret->{$otherrel} =  $otherrel_info;
-    }
+    my $other_rel_info = $other_rsrc->relationship_info($other_rel);
+
+    # this can happen when we have a self-referential class
+    next if $other_rel_info eq $rel_info;
+
+    next unless ref $other_rel_info->{cond} eq 'HASH';
+    my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
+
+    $ret->{$other_rel} = $other_rel_info if (
+      $self->_compare_relationship_keys (
+        [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
+      )
+        and
+      $self->_compare_relationship_keys (
+        [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
+      )
+    );
   }
+
   return $ret;
 }
 
+# all this does is removes the foreign/self prefix from a condition
+sub __strip_relcond {
+  +{
+    map
+      { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
+      keys %{$_[1]}
+  }
+}
+
 sub compare_relationship_keys {
   carp 'compare_relationship_keys is a private method, stop calling it';
   my $self = shift;
@@ -1385,36 +1402,12 @@ sub compare_relationship_keys {
 
 # Returns true if both sets of keynames are the same, false otherwise.
 sub _compare_relationship_keys {
-  my ($self, $keys1, $keys2) = @_;
-
-  # Make sure every keys1 is in keys2
-  my $found;
-  foreach my $key (@$keys1) {
-    $found = 0;
-    foreach my $prim (@$keys2) {
-      if ($prim eq $key) {
-        $found = 1;
-        last;
-      }
-    }
-    last unless $found;
-  }
-
-  # Make sure every key2 is in key1
-  if ($found) {
-    foreach my $prim (@$keys2) {
-      $found = 0;
-      foreach my $key (@$keys1) {
-        if ($prim eq $key) {
-          $found = 1;
-          last;
-        }
-      }
-      last unless $found;
-    }
-  }
-
-  return $found;
+#  my ($self, $keys1, $keys2) = @_;
+  return
+    join ("\x00", sort @{$_[1]})
+      eq
+    join ("\x00", sort @{$_[2]})
+  ;
 }
 
 # Returns the {from} structure used to express JOIN conditions
@@ -1493,7 +1486,8 @@ sub _resolve_join {
                -alias => $as,
                -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
              },
-             $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) ];
+             $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join)
+          ];
   }
 }
 
@@ -1545,38 +1539,89 @@ sub resolve_condition {
   $self->_resolve_condition (@_);
 }
 
-# Resolves the passed condition to a concrete query fragment. If given an alias,
-# returns a join condition; if given an object, inverts that object to produce
-# a related conditional from that object.
-our $UNRESOLVABLE_CONDITION = \'1 = 0';
+our $UNRESOLVABLE_CONDITION = \ '1 = 0';
 
+# Resolves the passed condition to a concrete query fragment and a flag
+# indicating whether this is a cross-table condition. Also an optional
+# list of non-triviail values (notmally conditions) returned as a part
+# of a joinfree condition hash
 sub _resolve_condition {
-  my ($self, $cond, $as, $for, $rel) = @_;
+  my ($self, $cond, $as, $for, $relname) = @_;
+
+  my $obj_rel = !!blessed $for;
+
   if (ref $cond eq 'CODE') {
+    my $relalias = $obj_rel ? 'me' : $as;
+
+    my ($crosstable_cond, $joinfree_cond) = $cond->({
+      self_alias => $obj_rel ? $as : $for,
+      foreign_alias => $relalias,
+      self_resultsource => $self,
+      foreign_relname => $relname || ($obj_rel ? $as : $for),
+      self_rowobj => $obj_rel ? $for : undef
+    });
 
-    # heuristic for the actual relname
-    if (! defined $rel) {
-      if (!ref $as) {
-        $rel = $as;
+    my $cond_cols;
+    if ($joinfree_cond) {
+
+      # FIXME sanity check until things stabilize, remove at some point
+      $self->throw_exception (
+        "A join-free condition returned for relationship '$relname' whithout a row-object to chain from"
+      ) unless $obj_rel;
+
+      # FIXME another sanity check
+      if (
+        ref $joinfree_cond ne 'HASH'
+          or
+        first { $_ !~ /^\Q$relalias.\E.+/ } keys %$joinfree_cond
+      ) {
+        $self->throw_exception (
+          "The join-free condition returned for relationship '$relname' must be a hash "
+         .'reference with all keys being valid columns on the related result source'
+        );
       }
-      elsif (!ref $for) {
-        $rel = $for;
+
+      # normalize
+      for (values %$joinfree_cond) {
+        $_ = $_->{'='} if (
+          ref $_ eq 'HASH'
+            and
+          keys %$_ == 1
+            and
+          exists $_->{'='}
+        );
       }
-    }
 
-    if (! defined $rel) {
-      $self->throw_exception ('Unable to determine relationship name for condition resolution');
-    }
+      # see which parts of the joinfree cond are conditionals
+      my $relcol_list = { map { $_ => 1 } $self->related_source($relname)->columns };
 
-    return $cond->({
-      self_alias => ref $for ? $as : $for,
-      foreign_alias => ref $for ? $self->related_source($rel)->resultset->current_source_alias : $as,
-      self_resultsource => $self,
-      foreign_relname => $rel,
-      self_rowobj => ref $for ? $for : undef
-    });
+      for my $c (keys %$joinfree_cond) {
+        my ($colname) = $c =~ /^ (?: \Q$relalias.\E )? (.+)/x;
 
-  } elsif (ref $cond eq 'HASH') {
+        unless ($relcol_list->{$colname}) {
+          push @$cond_cols, $colname;
+          next;
+        }
+
+        if (
+          ref $joinfree_cond->{$c}
+            and
+          ref $joinfree_cond->{$c} ne 'SCALAR'
+            and
+          ref $joinfree_cond->{$c} ne 'REF'
+        ) {
+          push @$cond_cols, $colname;
+          next;
+        }
+      }
+
+      return wantarray ? ($joinfree_cond, 0, $cond_cols) : $joinfree_cond;
+    }
+    else {
+      return wantarray ? ($crosstable_cond, 1) : $crosstable_cond;
+    }
+  }
+  elsif (ref $cond eq 'HASH') {
     my %ret;
     foreach my $k (keys %{$cond}) {
       my $v = $cond->{$k};
@@ -1613,18 +1658,29 @@ sub _resolve_condition {
       } elsif (!defined $as) { # undef, i.e. "no reverse object"
         $ret{$v} = undef;
       } else {
-        $ret{"${as}.${k}"} = "${for}.${v}";
+        $ret{"${as}.${k}"} = { -ident => "${for}.${v}" };
       }
     }
-    return \%ret;
-  } elsif (ref $cond eq 'ARRAY') {
-    return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
-  } else {
-    $self->throw_exception ("Can't handle condition $cond yet :(");
+
+    return wantarray
+      ? ( \%ret, ($obj_rel || !defined $as || ref $as) ? 0 : 1 )
+      : \%ret
+    ;
+  }
+  elsif (ref $cond eq 'ARRAY') {
+    my (@ret, $crosstable);
+    for (@$cond) {
+      my ($cond, $crosstab) = $self->_resolve_condition($_, $as, $for, $relname);
+      push @ret, $cond;
+      $crosstable ||= $crosstab;
+    }
+    return wantarray ? (\@ret, $crosstable) : \@ret;
+  }
+  else {
+    $self->throw_exception ("Can't handle condition $cond for relationship '$relname' yet :(");
   }
 }
 
-
 # Accepts one or more relationships for the current source and returns an
 # array of column names for each of those relationships. Column names are
 # prefixed relative to the current source, in accordance with where they appear
@@ -1675,7 +1731,7 @@ sub _resolve_prefetch {
     if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') {
       $self->throw_exception(
         "Can't prefetch has_many ${pre} (join cond too complex)")
-        unless (ref($rel_info->{cond}) eq 'HASH' || ref($rel_info->{cond}) eq 'CODE');
+        unless ref($rel_info->{cond}) eq 'HASH';
       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
 
       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
@@ -1697,17 +1753,9 @@ sub _resolve_prefetch {
       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ];
         # action at a distance. prepending the '.' allows simpler code
         # in ResultSet->_collapse_result
-
-      if (ref $rel_info->{cond} eq 'HASH') {
-        my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
-          keys %{$rel_info->{cond}};
-        push @$order, map { "${as}.$_" } @key;
-      } else { # ref $rel_info->{cond} eq 'CODE'
-        # call the cond to get the keys...
-        my $cond_data = $rel_info->{cond}->({ foreign_alias => $as,
-                                              self_alias => $alias });
-        push @$order, keys %$cond_data;
-      }
+      my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
+                    keys %{$rel_info->{cond}};
+      push @$order, map { "${as}.$_" } @key;
 
       if (my $rel_order = $rel_info->{attrs}{order_by}) {
         # this is kludgy and incomplete, I am well aware
@@ -1760,7 +1808,18 @@ sub related_source {
   if( !$self->has_relationship( $rel ) ) {
     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
   }
-  return $self->schema->source($self->relationship_info($rel)->{source});
+
+  # if we are not registered with a schema - just use the prototype
+  # however if we do have a schema - ask for the source by name (and
+  # throw in the process if all fails)
+  if (my $schema = try { $self->schema }) {
+    $schema->source($self->relationship_info($rel)->{source});
+  }
+  else {
+    my $class = $self->relationship_info($rel)->{class};
+    $self->ensure_class_loaded($class);
+    $class->result_source_instance;
+  }
 }
 
 =head2 related_class
@@ -1817,7 +1876,10 @@ sub handle {
 {
   my $global_phase_destroy;
 
-  END { $global_phase_destroy++ }
+  # SpeedyCGI runs END blocks every cycle but keeps object instances
+  # hence we have to disable the globaldestroy hatch, and rely on the
+  # eval trap below (which appears to work, but is risky done so late)
+  END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy }
 
   sub DESTROY {
     return if $global_phase_destroy;
@@ -1840,23 +1902,34 @@ sub handle {
     );
 
     # weaken our schema hold forcing the schema to find somewhere else to live
-    weaken $_[0]->{schema};
+    # during global destruction (if we have not yet bailed out) this will throw
+    # which will serve as a signal to not try doing anything else
+    local $@;
+    eval {
+      weaken $_[0]->{schema};
+      1;
+    } or do {
+      $global_phase_destroy = 1;
+      return;
+    };
+
 
-    # if schema is still there reintroduce ourselves with strong refs back
+    # if schema is still there reintroduce ourselves with strong refs back to us
     if ($_[0]->{schema}) {
       my $srcregs = $_[0]->{schema}->source_registrations;
       for (keys %$srcregs) {
+        next unless $srcregs->{$_};
         $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
       }
     }
   }
 }
 
-sub STORABLE_freeze { nfreeze($_[0]->handle) }
+sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
 
 sub STORABLE_thaw {
   my ($self, $cloning, $ice) = @_;
-  %$self = %{ (thaw $ice)->resolve };
+  %$self = %{ (Storable::thaw($ice))->resolve };
 }
 
 =head2 throw_exception