X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBIHacks.pm;h=cb75f142ecd3d28e7f549519fc45d5a8c4606062;hb=946f626022c63fd269d9d985c2abeabb52871027;hp=10dd17872bbf8bbf3a7d2cfbde88531b8af54689;hpb=6395604e3a53f12676a9bd7d51a6f113cc0d855b;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm
index 10dd178..cb75f14 100644
--- a/lib/DBIx/Class/Storage/DBIHacks.pm
+++ b/lib/DBIx/Class/Storage/DBIHacks.pm
@@ -4,7 +4,7 @@ package   #hide from PAUSE
 #
 # This module contains code that should never have seen the light of day,
 # does not belong in the Storage, or is otherwise unfit for public
-# display. The arrival of SQLA2 should immediately oboslete 90% of this
+# display. The arrival of SQLA2 should immediately obsolete 90% of this
 #
 
 use strict;
@@ -15,6 +15,7 @@ use mro 'c3';
 
 use List::Util 'first';
 use Scalar::Util 'blessed';
+use Sub::Name 'subname';
 use namespace::clean;
 
 #
@@ -39,7 +40,14 @@ sub _prune_unused_joins {
 
   my @newfrom = $from->[0]; # FROM head is always present
 
-  my %need_joins = (map { %{$_||{}} } (values %$aliastypes) );
+  my %need_joins;
+  for (values %$aliastypes) {
+    # add all requested aliases
+    $need_joins{$_} = 1 for keys %$_;
+
+    # add all their parents (as per joinpath which is an AoH { table => alias })
+    $need_joins{$_} = 1 for map { values %$_ } map { @$_ } values %$_;
+  }
   for my $j (@{$from}[1..$#$from]) {
     push @newfrom, $j if (
       (! $j->[0]{-alias}) # legacy crap
@@ -53,7 +61,7 @@ sub _prune_unused_joins {
 
 #
 # This is the code producing joined subqueries like:
-# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ... 
+# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ...
 #
 sub _adjust_select_args_for_complex_prefetch {
   my ($self, $from, $select, $where, $attrs) = @_;
@@ -64,23 +72,15 @@ sub _adjust_select_args_for_complex_prefetch {
   $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
     if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY');
 
-
   # generate inner/outer attribute lists, remove stuff that doesn't apply
   my $outer_attrs = { %$attrs };
   delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/;
 
-  my $inner_attrs = { %$attrs };
-  delete $inner_attrs->{$_} for qw/for collapse _prefetch_selector_range _collapse_order_by select as/;
+  my $inner_attrs = { %$attrs, _is_internal_subuery => 1 };
+  delete $inner_attrs->{$_} for qw/for collapse _prefetch_selector_range select as/;
 
-
-  # bring over all non-collapse-induced order_by into the inner query (if any)
-  # the outer one will have to keep them all
-  delete $inner_attrs->{order_by};
-  if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}} ) {
-    $inner_attrs->{order_by} = [
-      @{$outer_attrs->{order_by}}[ 0 .. $ord_cnt - 1]
-    ];
-  }
+  # if the user did not request it, there is no point using it inside
+  delete $inner_attrs->{order_by} if delete $inner_attrs->{_order_is_artificial};
 
   # generate the inner/outer select lists
   # for inside we consider only stuff *not* brought in by the prefetch
@@ -119,8 +119,8 @@ sub _adjust_select_args_for_complex_prefetch {
     my $inner_aliastypes =
       $self->_resolve_aliastypes_from_select_args( $inner_from, $inner_select, $where, $inner_attrs );
 
-    # if a multi-type non-selecting (only restricting) join was needed in the subquery
-    # add a group_by to simulate the collapse in the subq
+    # we need to simulate collapse in the subq if a multiplying join is pulled
+    # by being a non-selecting restrictor
     if (
       ! $inner_attrs->{group_by}
         and
@@ -193,20 +193,26 @@ sub _adjust_select_args_for_complex_prefetch {
   my $outer_aliastypes =
     $self->_resolve_aliastypes_from_select_args( $from, $outer_select, $where, $outer_attrs );
 
+  # unroll parents
+  my ($outer_select_chain, $outer_restrict_chain) = map { +{
+    map { $_ => 1 } map { values %$_} map { @$_ } values %{ $outer_aliastypes->{$_} || {} }
+  } } qw/selecting restricting/;
+
   # see what's left - throw away if not selecting/restricting
-  # also throw in a group_by if restricting to guard against
-  # cross-join explosions
-  #
+  # also throw in a group_by if a non-selecting multiplier,
+  # to guard against cross-join explosions
   my $need_outer_group_by;
   while (my $j = shift @$from) {
     my $alias = $j->[0]{-alias};
 
-    if ($outer_aliastypes->{selecting}{$alias}) {
-      push @outer_from, $j;
+    if (
+      $outer_select_chain->{$alias}
+    ) {
+      push @outer_from, $j
     }
-    elsif ($outer_aliastypes->{restricting}{$alias}) {
+    elsif ($outer_restrict_chain->{$alias}) {
       push @outer_from, $j;
-      $need_outer_group_by ||= ! $j->[0]{-is_single};
+      $need_outer_group_by ||= $outer_aliastypes->{multiplying}{$alias} ? 1 : 0;
     }
   }
 
@@ -267,8 +273,13 @@ sub _resolve_aliastypes_from_select_args {
       or next;
 
     $alias_list->{$al} = $j;
-    $aliases_by_type->{multiplying}{$al} = 1
-      if ref($_) eq 'ARRAY' and ! $j->{-is_single}; # not array == {from} head == can't be multiplying
+    $aliases_by_type->{multiplying}{$al} ||= $j->{-join_path}||[] if (
+      # not array == {from} head == can't be multiplying
+      ( ref($_) eq 'ARRAY' and ! $j->{-is_single} )
+        or
+      # a parent of ours is already a multiplier
+      ( grep { $aliases_by_type->{multiplying}{$_} } @{ $j->{-join_path}||[] } )
+    );
   }
 
   # get a column to source/alias map (including unqualified ones)
@@ -329,7 +340,8 @@ sub _resolve_aliastypes_from_select_args {
 
     for my $type (keys %$to_scan) {
       for my $piece (@{$to_scan->{$type}}) {
-        $aliases_by_type->{$type}{$alias} = 1 if ($piece =~ $al_re);
+        $aliases_by_type->{$type}{$alias} ||= $alias_list->{$alias}{-join_path}||[]
+          if ($piece =~ $al_re);
       }
     }
   }
@@ -343,7 +355,10 @@ sub _resolve_aliastypes_from_select_args {
 
     for my $type (keys %$to_scan) {
       for my $piece (@{$to_scan->{$type}}) {
-        $aliases_by_type->{$type}{$colinfo->{$col}{-source_alias}} = 1 if ($piece =~ $col_re);
+        if ($piece =~ $col_re) {
+          my $alias = $colinfo->{$col}{-source_alias};
+          $aliases_by_type->{$type}{$alias} ||= $alias_list->{$alias}{-join_path}||[];
+        }
       }
     }
   }
@@ -351,22 +366,13 @@ sub _resolve_aliastypes_from_select_args {
   # Add any non-left joins to the restriction list (such joins are indeed restrictions)
   for my $j (values %$alias_list) {
     my $alias = $j->{-alias} or next;
-    $aliases_by_type->{restricting}{$alias} = 1 if (
+    $aliases_by_type->{restricting}{$alias} ||= $j->{-join_path}||[] if (
       (not $j->{-join_type})
         or
       ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
     );
   }
 
-  # mark all restricting/selecting join parents as such
-  # (e.g.  join => { cds => 'tracks' } - tracks will need to bring cds too )
-  for my $type (qw/restricting selecting/) {
-    for my $alias (keys %{$aliases_by_type->{$type}||{}}) {
-      $aliases_by_type->{$type}{$_} = 1
-        for (map { values %$_ } @{ $alias_list->{$alias}{-join_path} || [] });
-    }
-  }
-
   return $aliases_by_type;
 }
 
@@ -502,7 +508,11 @@ sub _resolve_column_info {
       },
       -result_source => $rsrc,
       -source_alias => $source_alias,
+      -fq_colname => $col eq $colname ? "$source_alias.$col" : $col,
+      -colname => $colname,
     };
+
+    $return{"$source_alias.$colname"} = $return{$col} if $col eq $colname;
   }
 
   return \%return;
@@ -555,7 +565,7 @@ sub _inner_join_to_node {
   # So it looks like we will have to switch some stuff around.
   # local() is useless here as we will be leaving the scope
   # anyway, and deep cloning is just too fucking expensive
-  # So replace the first hashref in the node arrayref manually 
+  # So replace the first hashref in the node arrayref manually
   my @new_from = ($from->[0]);
   my $sw_idx = { map { (values %$_), 1 } @$switch_branch }; #there's one k/v per join-path
 
@@ -578,64 +588,59 @@ sub _inner_join_to_node {
   return \@new_from;
 }
 
-# Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus
-# a condition containing 'me' or other table prefixes will not work
-# at all. What this code tries to do (badly) is introspect the condition
-# and remove all column qualifiers. If it bails out early (returns undef)
-# the calling code should try another approach (e.g. a subquery)
-
-sub _strip_cond_qualifiers_from_array {
-  my ($self, $where) = @_;
-  my @cond;
-  for (my $i = 0; $i < @$where; $i++) {
-    my $entry = $where->[$i];
-    my $hash;
-    my $ref = ref $entry;
-    if ($ref eq 'HASH' or $ref eq 'ARRAY') {
-      $hash = $self->_strip_cond_qualifiers($entry);
-    }
-    elsif (! $ref) {
-      $entry =~ /([^.]+)$/;
-      $hash->{$1} = $where->[++$i];
-    }
-    push @cond, $hash;
-  }
-  return \@cond;
-}
-
-sub _strip_cond_qualifiers {
-  my ($self, $where) = @_;
-
-  my $cond = {};
-
-  # No-op. No condition, we're updating/deleting everything
-  return $cond unless $where;
-
-  if (ref $where eq 'ARRAY') {
-    $cond = $self->_strip_cond_qualifiers_from_array($where);
-  }
-  elsif (ref $where eq 'HASH') {
-    if ( (keys %$where) == 1 && ( (keys %{$where})[0] eq '-and' )) {
-      $cond->{-and} =
-        $self->_strip_cond_qualifiers_from_array($where->{-and});
-    }
-    else {
-      foreach my $key (keys %$where) {
-        if ($key eq '-or' && ref $where->{$key} eq 'ARRAY') {
-          $cond->{$key} = $self->_strip_cond_qualifiers($where->{$key});
+# yet another atrocity: attempt to extract all columns from a
+# where condition by hooking _quote
+sub _extract_condition_columns {
+  my ($self, $cond, $sql_maker) = @_;
+
+  return [] unless $cond;
+
+  $sql_maker ||= $self->{_sql_ident_capturer} ||= do {
+    # FIXME - replace with a Moo trait
+    my $orig_sm_class = ref $self->sql_maker;
+    my $smic_class = "${orig_sm_class}::_IdentCapture_";
+
+    unless ($smic_class->isa('SQL::Abstract')) {
+
+      no strict 'refs';
+      *{"${smic_class}::_quote"} = subname "${smic_class}::_quote" => sub {
+        my ($self, $ident) = @_;
+        if (ref $ident eq 'SCALAR') {
+          $ident = $$ident;
+          my $storage_quotes = $self->sql_quote_char || '"';
+          my ($ql, $qr) = map
+            { quotemeta $_ }
+            (ref $storage_quotes eq 'ARRAY' ? @$storage_quotes : ($storage_quotes) x 2 )
+          ;
+
+          while ($ident =~ /
+            $ql (\w+) $qr
+              |
+            ([\w\.]+)
+          /xg) {
+            $self->{_captured_idents}{$1||$2}++;
+          }
         }
         else {
-          $key =~ /([^.]+)$/;
-          $cond->{$1} = $where->{$key};
+          $self->{_captured_idents}{$ident}++;
         }
-      }
+        return $ident;
+      };
+
+      *{"${smic_class}::_get_captured_idents"} = subname "${smic_class}::_get_captures" => sub {
+        (delete shift->{_captured_idents}) || {};
+      };
+
+      $self->inject_base ($smic_class, $orig_sm_class);
+
     }
-  }
-  else {
-    return undef;
-  }
 
-  return $cond;
+    $smic_class->new();
+  };
+
+  $sql_maker->_recurse_where($cond);
+
+  return [ sort keys %{$sql_maker->_get_captured_idents} ];
 }
 
 sub _extract_order_criteria {
@@ -667,4 +672,62 @@ sub _extract_order_criteria {
   }
 }
 
+sub _order_by_is_stable {
+  my ($self, $ident, $order_by, $where) = @_;
+
+  my $colinfo = $self->_resolve_column_info($ident, [
+    (map { $_->[0] } $self->_extract_order_criteria($order_by)),
+    $where ? @{$self->_extract_fixed_condition_columns($where)} :(),
+  ]);
+
+  return undef unless keys %$colinfo;
+
+  my $cols_per_src;
+  $cols_per_src->{$_->{-source_alias}}{$_->{-colname}} = $_ for values %$colinfo;
+
+  for (values %$cols_per_src) {
+    my $src = (values %$_)[0]->{-result_source};
+    return 1 if $src->_identifying_column_set($_);
+  }
+
+  return undef;
+}
+
+# returns an arrayref of column names which *definitely* have som
+# sort of non-nullable equality requested in the given condition
+# specification. This is used to figure out if a resultset is
+# constrained to a column which is part of a unique constraint,
+# which in turn allows us to better predict how ordering will behave
+# etc.
+#
+# this is a rudimentary, incomplete, and error-prone extractor
+# however this is OK - it is conservative, and if we can not find
+# something that is in fact there - the stack will recover gracefully
+# Also - DQ and the mst it rode in on will save us all RSN!!!
+sub _extract_fixed_condition_columns {
+  my ($self, $where, $nested) = @_;
+
+  return unless ref $where eq 'HASH';
+
+  my @cols;
+  for my $lhs (keys %$where) {
+    if ($lhs =~ /^\-and$/i) {
+      push @cols, ref $where->{$lhs} eq 'ARRAY'
+        ? ( map { $self->_extract_fixed_condition_columns($_, 1) } @{$where->{$lhs}} )
+        : $self->_extract_fixed_condition_columns($where->{$lhs}, 1)
+      ;
+    }
+    elsif ($lhs !~ /^\-/) {
+      my $val = $where->{$lhs};
+
+      push @cols, $lhs if (defined $val and (
+        ! ref $val
+          or
+        (ref $val eq 'HASH' and keys %$val == 1 and defined $val->{'='})
+      ));
+    }
+  }
+  return $nested ? @cols : \@cols;
+}
+
 1;