Switch reverse_relationship_info() to the relcond resolver

Prompted by a PR from @mzealey, a code audit showed the entire implementation to be severely lacking. Switched to proper relationship resolution, with the added benefit of support for custom conds whenever possible. As of this commit every single relationship introspection now goes through a central point: _resolve_relationship_condition(). No more random ... eq 'HASH' checks all over the place. There should be zero functional changes as a result (aside from better custom cond introspection)
Perl5 · Sep 27, 2016 · 86be9bc · 86be9bc
1 parent a3ae79e
commit 86be9bc
Show file tree

Hide file tree

Showing 6 changed files with 155 additions and 73 deletions.
diff --git a/.mailmap b/.mailmap
@@ -37,6 +37,7 @@ Jason M. Mills <jmmills@cpan.org>           <jmmills@cpan.org>
 Jonathan Chu <milki@rescomp.berkeley.edu>   <milki@rescomp.berkeley.edu>
 Jose Luis Martinez <jlmartinez@capside.com> <jlmartinez@capside.com>
 Kent Fredric <kentnl@cpan.org>              <kentfredric@gmail.com>
+Mark Zealey <mark@dns-consultants.com>      <mark@markandruth.co.uk>
 Matt Phillips <mattp@cpan.org>              <mphillips@oanda.com>
 Matt Phillips <mattp@cpan.org>              <matt@raybec.com>
 Michael Reddick <michael.reddick@gmail.com> <michaelr@michaelr-desktop.(none)>

diff --git a/AUTHORS b/AUTHORS
@@ -97,6 +97,7 @@ ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
 ingy: Ingy döt Net <ingy@ingy.net>
 initself: Mike Baas <mike@initselftech.com>
 ironcamel: Naveed Massjouni <naveedm9@gmail.com>
+jalh: Mark Zealey <mark@dns-consultants.com>
 jasonmay: Jason May <jason.a.may@gmail.com>
 jawnsy: Jonathan Yu <jawnsy@cpan.org>
 jegade: Jens Gassmann <jens.gassmann@atomix.de>

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
@@ -17,9 +17,9 @@ use base 'DBIx::Class::ResultSource::RowParser';
 
 use DBIx::Class::Carp;
 use DBIx::Class::_Util qw(
-  UNRESOLVABLE_CONDITION
+  UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR
   dbic_internal_try fail_on_internal_call
-  refdesc emit_loud_diag dump_value
+  refdesc emit_loud_diag dump_value serialize bag_eq
 );
 use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions );
 use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info';
@@ -1824,85 +1824,111 @@ L</relationship_info>.
 sub reverse_relationship_info {
   my ($self, $rel) = @_;
 
-  my $rel_info = $self->relationship_info($rel)
-    or $self->throw_exception("No such relationship '$rel'");
+  # This may be a partial schema or something else equally esoteric
+  # in which case this will throw
+  #
+  my $other_rsrc = $self->related_source($rel);
 
-  my $ret = {};
+  # Some custom rels may not resolve without a $schema
+  #
+  my $our_resolved_relcond = dbic_internal_try {
+    $self->_resolve_relationship_condition(
+      rel_name => $rel,
 
-  return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
+      # an API where these are optional would be too cumbersome,
+      # instead always pass in some dummy values
+      DUMMY_ALIASPAIR,
+    )
+  };
 
-  my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
+  # only straight-equality is compared
+  return {}
+    unless $our_resolved_relcond->{identity_map_matches_condition};
 
-  my $registered_source_name = $self->source_name;
+  my( $our_registered_source_name, $our_result_class) =
+    ( $self->source_name, $self->result_class );
 
-  # this may be a partial schema or something else equally esoteric
-  my $other_rsrc = $self->related_source($rel);
+  my $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
   foreach my $other_rel ($other_rsrc->relationships) {
 
+    # this will happen when we have a self-referential class
+    next if (
+      $other_rel eq $rel
+        and
+      $self == $other_rsrc
+    );
+
     # 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 = dbic_internal_try { $other_rsrc->related_source($other_rel) }
-      or next;
+    my $roundtripped_rsrc;
+    next unless (
 
-    if ($registered_source_name) {
-      next if $registered_source_name ne ($roundtrip_rsrc->source_name || '')
-    }
-    else {
-      next if $self->result_class ne $roundtrip_rsrc->result_class;
-    }
+      # the schema may be partially loaded
+      $roundtripped_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) }
+
+        and
 
-    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;
+        (
+          $our_registered_source_name
+            and
+          (
+            $our_registered_source_name
+              eq
+            $roundtripped_rsrc->source_name||''
+          )
+        )
 
-    next unless ref $other_rel_info->{cond} eq 'HASH';
-    my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
+          or
 
-    $ret->{$other_rel} = $other_rel_info if (
-      $self->_compare_relationship_keys (
-        [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
+        (
+          $our_result_class
+            eq
+          $roundtripped_rsrc->result_class
+        )
       )
+
         and
-      $self->_compare_relationship_keys (
-        [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
-      )
+
+      my $their_resolved_relcond = dbic_internal_try {
+        $other_rsrc->_resolve_relationship_condition(
+          rel_name => $other_rel,
+
+          # an API where these are optional would be too cumbersome,
+          # instead always pass in some dummy values
+          DUMMY_ALIASPAIR,
+        )
+      }
     );
-  }
 
-  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]}
-  }
-}
+    $ret->{$other_rel} = $other_rsrc->relationship_info($other_rel) if (
 
-sub compare_relationship_keys {
-  carp 'compare_relationship_keys is a private method, stop calling it';
-  my $self = shift;
-  $self->_compare_relationship_keys (@_);
-}
+      $their_resolved_relcond->{identity_map_matches_condition}
 
-# Returns true if both sets of keynames are the same, false otherwise.
-sub _compare_relationship_keys {
-#  my ($self, $keys1, $keys2) = @_;
-  return
-    join ("\x00", sort @{$_[1]})
-      eq
-    join ("\x00", sort @{$_[2]})
-  ;
+        and
+
+      keys %{ $our_resolved_relcond->{identity_map} }
+        ==
+      keys %{ $their_resolved_relcond->{identity_map} }
+
+        and
+
+      serialize( $our_resolved_relcond->{identity_map} )
+        eq
+      serialize( { reverse %{ $their_resolved_relcond->{identity_map} } } )
+
+    );
+  }
+
+  return $ret;
 }
 
 # optionally takes either an arrayref of column names, or a hashref of already
@@ -2124,6 +2150,25 @@ sub _pk_depends_on {
   return 1;
 }
 
+sub __strip_relcond :DBIC_method_is_indirect_sugar {
+  DBIx::Class::Exception->throw(
+    '__strip_relcond() has been removed with no replacement, '
+  . 'ask for advice on IRC if this affected you'
+  );
+}
+
+sub compare_relationship_keys :DBIC_method_is_indirect_sugar {
+  DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
+  carp_unique( 'compare_relationship_keys() is deprecated, ask on IRC for a better alternative' );
+  bag_eq( $_[1], $_[2] );
+}
+
+sub _compare_relationship_keys :DBIC_method_is_indirect_sugar {
+  DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
+  carp_unique( '_compare_relationship_keys() is deprecated, ask on IRC for a better alternative' );
+  bag_eq( $_[1], $_[2] );
+}
+
 sub resolve_condition {
   carp 'resolve_condition is a private method, stop calling it';
   shift->_resolve_condition (@_);
@@ -2259,7 +2304,7 @@ sub _resolve_relationship_condition {
     if $args->{self_alias} eq $args->{foreign_alias};
 
 # TEMP
-  my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'";
+  my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name || $self->result_class ]}'";
 
   my $rel_info = $self->relationship_info($args->{rel_name})
 # TEMP
@@ -2462,7 +2507,10 @@ sub _resolve_relationship_condition {
     # construct the crosstable condition and the identity map
     for  (0..$#f_cols) {
       $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" };
-      $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_];
+
+      # explicit value stringification is deliberate - leave no room for
+      # interpretation when comparing sets of keys
+      $ret->{identity_map}{$l_cols[$_]} = "$f_cols[$_]";
     };
 
     if ($args->{foreign_values}) {
@@ -2666,8 +2714,11 @@ sub _resolve_relationship_condition {
           $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias}
         ) {
           ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} )
-            ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} )
-            : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} )
+
+            # explicit value stringification is deliberate - leave no room for
+            # interpretation when comparing sets of keys
+            ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = "$colinfos->{$rhs_ref->[0]}{-colname}" )
+            : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = "$colinfos->{$lhs}{-colname}" )
           ;
 
           # well, what do you know!

diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm
@@ -457,12 +457,15 @@ sub _resolve_collapse {
 
         is_single => $relinfo->{$rel}{is_single},
 
-        # if there is at least one *inner* reverse relationship which is HASH-based (equality only)
+        # if there is at least one *inner* reverse relationship ( meaning identity-only )
         # we can safely assume that the child can not exist without us
-        rev_rel_is_optional => ( grep
-          { ref $_->{cond} eq 'HASH' and ($_->{attrs}{join_type}||'') !~ /^left/i }
-          values %{ $self->reverse_relationship_info($rel) },
-        ) ? 0 : 1,
+        rev_rel_is_optional => (
+          ( grep {
+            ($_->{attrs}{join_type}||'') !~ /^left/i
+          } values %{ $self->reverse_relationship_info($rel) } )
+            ? 0
+            : 1
+        ),
 
         # if this is a 1:1 our own collapser can be used as a collapse-map
         # (regardless of left or not)

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
@@ -204,7 +204,7 @@ our @EXPORT_OK = qw(
   scope_guard detected_reinvoked_destructor emit_loud_diag
   true false
   is_exception dbic_internal_try dbic_internal_catch visit_namespaces
-  quote_sub qsub perlstring serialize deep_clone dump_value uniq
+  quote_sub qsub perlstring serialize deep_clone dump_value uniq bag_eq
   parent_dir mkdir_p
   UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR
 );
@@ -387,6 +387,34 @@ sub uniq {
   ) } @_;
 }
 
+sub bag_eq ($$) {
+  croak "bag_eq() requiress two arrayrefs as arguments" if (
+    ref($_[0]) ne 'ARRAY'
+      or
+    ref($_[1]) ne 'ARRAY'
+  );
+
+  return '' unless @{$_[0]} == @{$_[1]};
+
+  my( %seen, $numeric_preserving_copy );
+
+  ( defined $_
+    ? $seen{'value' . ( $numeric_preserving_copy = $_ )}++
+    : $seen{'undef'}++
+  ) for @{$_[0]};
+
+  ( defined $_
+    ? $seen{'value' . ( $numeric_preserving_copy = $_ )}--
+    : $seen{'undef'}--
+  ) for @{$_[1]};
+
+  return (
+    (grep { $_ } values %seen)
+      ? ''
+      : 1
+  );
+}
+
 my $dd_obj;
 sub dump_value ($) {
   local $Data::Dumper::Indent = 1

diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm
@@ -15,7 +15,7 @@ $DEBUG = 0 unless defined $DEBUG;
 use Exporter;
 use SQL::Translator::Utils qw(debug normalize_name);
 use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
-use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch );
+use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch bag_eq );
 use Class::C3::Componentised;
 use Scalar::Util 'blessed';
 use namespace::clean;
@@ -155,13 +155,11 @@ sub parse {
 
         my %unique_constraints = $source->unique_constraints;
         foreach my $uniq (sort keys %unique_constraints) {
-            if (!$source->_compare_relationship_keys($unique_constraints{$uniq}, \@primary)) {
-                $table->add_constraint(
-                            type             => 'unique',
-                            name             => $uniq,
-                            fields           => $unique_constraints{$uniq}
-                );
-            }
+            $table->add_constraint(
+                type             => 'unique',
+                name             => $uniq,
+                fields           => $unique_constraints{$uniq}
+            ) unless bag_eq( \@primary, $unique_constraints{$uniq} );
         }
 
         my @rels = $source->relationships();
@@ -232,7 +230,7 @@ sub parse {
             # this is supposed to indicate a has_one/might_have...
             # where's the introspection!!?? :)
             else {
-                $fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary);
+                $fk_constraint = ! bag_eq( \@keys, \@primary );
             }