Merge branch 'current/for_cpan_index' into current/dq
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSet.pm
index 027a064..d6c5e9b 100644 (file)
@@ -6,8 +6,9 @@ use base qw/DBIx::Class/;
 use DBIx::Class::Carp;
 use DBIx::Class::ResultSetColumn;
 use Scalar::Util qw/blessed weaken reftype/;
+use DBIx::Class::_Util 'fail_on_internal_wantarray';
 use Try::Tiny;
-use Data::Compare (); # no imports!!! guard against insane architecture
+use Data::Dumper::Concise ();
 use Data::Query::Constants;
 use Data::Query::ExprHelpers;
 # not importing first() as it will clash with our own method
@@ -247,7 +248,7 @@ sub new {
     if $source->isa('DBIx::Class::ResultSourceHandle');
 
   $attrs = { %{$attrs||{}} };
-  delete @{$attrs}{qw(_sqlmaker_select_args _related_results_construction)};
+  delete @{$attrs}{qw(_last_sqlmaker_alias_map _related_results_construction)};
 
   if ($attrs->{page}) {
     $attrs->{rows} ||= 10;
@@ -305,7 +306,7 @@ call it as C<search(undef, \%attrs)>.
 
 For a list of attributes that can be passed to C<search>, see
 L</ATTRIBUTES>. For more examples of using this function, see
-L<Searching|DBIx::Class::Manual::Cookbook/Searching>. For a complete
+L<Searching|DBIx::Class::Manual::Cookbook/SEARCHING>. For a complete
 documentation for the first argument, see L<SQL::Abstract/"WHERE CLAUSES">
 and its extension L<DBIx::Class::SQLMaker>.
 
@@ -328,6 +329,7 @@ sub search {
   my $rs = $self->search_rs( @_ );
 
   if (wantarray) {
+    DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray($rs);
     return $rs->all;
   }
   elsif (defined wantarray) {
@@ -396,6 +398,10 @@ sub search_rs {
     $call_cond = { @_ };
   }
 
+  if (blessed($call_cond) and $call_cond->isa('Data::Query::ExprBuilder')) {
+    $call_cond = \$call_cond->{expr};
+  }
+
   # see if we can keep the cache (no $rs changes)
   my $cache;
   my %safe = (alias => 1, cache => 1);
@@ -407,6 +413,18 @@ sub search_rs {
     ref $call_cond eq 'ARRAY' && ! @$call_cond
   )) {
     $cache = $self->get_cache;
+  } elsif (
+    $self->{attrs}{cache} and
+    ($self->{attrs}{grep_cache} or $call_attrs->{grep_cache})
+  ) {
+    if (
+      keys %$call_attrs
+      and not (exists $call_attrs->{grep_cache} and !$call_attrs->{grep_cache})
+    ) {
+      die "Can't do complex search on resultset with grep_cache set";
+    }
+    my $grep_one = $self->_construct_perl_predicate($call_cond);
+    $cache = [ grep $grep_one->($_), $self->all ];
   }
 
   my $old_attrs = { %{$self->{attrs}} };
@@ -584,60 +602,104 @@ sub _normalize_selection {
 sub _stack_cond {
   my ($self, $left, $right) = @_;
 
-  # collapse single element top-level conditions
-  # (single pass only, unlikely to need recursion)
-  for ($left, $right) {
-    if (ref $_ eq 'ARRAY') {
-      if (@$_ == 0) {
-        $_ = undef;
-      }
-      elsif (@$_ == 1) {
-        $_ = $_->[0];
-      }
-    }
-    elsif (ref $_ eq 'HASH') {
-      my ($first, $more) = keys %$_;
+  my $source = $self->result_source;
 
-      # empty hash
-      if (! defined $first) {
-        $_ = undef;
-      }
-      # one element hash
-      elsif (! defined $more) {
-        if ($first eq '-and' and ref $_->{'-and'} eq 'HASH') {
-          $_ = $_->{'-and'};
-        }
-        elsif ($first eq '-or' and ref $_->{'-or'} eq 'ARRAY') {
-          $_ = $_->{'-or'};
-        }
-      }
-    }
-  }
+  my $converter = $source->schema->storage->sql_maker->converter;
 
-  # merge hashes with weeding out of duplicates (simple cases only)
-  if (ref $left eq 'HASH' and ref $right eq 'HASH') {
+  my @top = map $source->_extract_top_level_conditions(
+    $converter->_expr_to_dq($_)
+  ), grep defined, $left, $right;
 
-    # shallow copy to destroy
-    $right = { %$right };
-    for (grep { exists $right->{$_} } keys %$left) {
-      # the use of eq_deeply here is justified - the rhs of an
-      # expression can contain a lot of twisted weird stuff
-      delete $right->{$_} if Data::Compare::Compare( $left->{$_}, $right->{$_} );
-    }
+  return undef unless @top;
 
-    $right = undef unless keys %$right;
-  }
+  my %seen;
 
+  my @uniq = grep { !$seen{Data::Dumper::Concise::Dumper($_)}++ } @top;
 
-  if (defined $left xor defined $right) {
-    return defined $left ? $left : $right;
-  }
-  elsif (! defined $left) {
-    return undef;
-  }
-  else {
-    return { -and => [ $left, $right ] };
+  return \$uniq[0] if @uniq == 1;
+
+  return \Operator({ 'SQL.Naive' => 'AND' }, \@uniq);
+}
+
+my %perl_op_map = (
+  '=' => { numeric => '==', string => 'eq' },
+);
+
+sub _construct_perl_predicate {
+  my ($self, $cond) = @_;
+
+  # This shouldn't really live here but it'll do for the moment.
+
+  my %alias_map = (
+    $self->current_source_alias => {
+      join_path => [],
+      source => $self->result_source,
+      columns_info => $self->result_source->columns_info,
+    },
+  );
+
+  my $attrs = $self->_resolved_attrs;
+  foreach my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) {
+    next unless $j->[0]{-alias};
+    next unless $j->[0]{-join_path};
+    $alias_map{$j->[0]{-alias}} = {
+      join_path => [ map { keys %$_ } @{$j->[0]{-join_path}} ],
+      source => $j->[0]{-rsrc},
+      columns_info => $j->[0]{-rsrc}->columns_info,
+    };
   }
+
+  my %as_map = map +($attrs->{select}[$_] => $attrs->{as}[$_]),
+                 grep !ref($attrs->{select}[$_]), 0..$#{$attrs->{select}};
+
+  my $storage = $self->result_source->schema->storage;
+  my $sql_maker = $storage->sql_maker;
+  my $tree = map_dq_tree {
+    if (is_Operator) {
+      my $op = $_->{operator}{'SQL.Naive'} or die "No operator";
+      if (lc($op) =~ /^(?:and|or|not)$/i) {
+        return Operator({ 'Perl' => lc($op) }, $op->{args});
+      }
+      if (my $op_map = $perl_op_map{$op}) {
+        die "Binop doesn't have two args - wtf?"
+          unless @{$_->{args}} == 2;
+        my $data_type;
+        my @mapped_args = map {
+          if (is_Identifier) {
+            die "Identifier not alias.colname"
+              unless @{$_->{elements}} == 2;
+            my ($alias, $col) = @{$_->{elements}};
+            die "${alias}.${col} not selected"
+              unless $as_map{"${alias}.${col}"};
+            unless ($data_type) {
+              my $colinfo = $alias_map{$alias}{columns_info}{$col};
+              unless (defined $colinfo->{is_numeric}) {
+                $colinfo->{is_numeric} = (
+                  $storage->is_datatype_numeric($colinfo->{data_type})
+                    ? 1
+                    : 0
+                );
+              }
+              $data_type = $colinfo->{is_numeric} ? 'numeric' : 'string';
+            }
+            Identifier(@{$alias_map{$alias}{join_path}}, $col);
+          } elsif (is_Value) {
+            $_;
+          } else {
+            die "Argument to operator neither identifier nor value";
+          }
+        } @{$_->{args}};
+        die "Couldn't determine numeric versus string" unless $data_type;
+        return \Operator({ Perl => $op_map->{$data_type} }, \@mapped_args);
+      }
+    }
+    die "Unable to map node to perl";
+  } $sql_maker->converter->_where_to_dq($cond);
+  my ($code, @values) = @{$storage->perl_renderer->render($tree)};
+  my $sub = eval q!sub { !.$code.q! }!
+    or die "Failed to build sub: $@";
+  my @args = map $_->{value}, @values;
+  return sub { local $_ = $_[0]; $sub->(@args) };
 }
 
 =head2 search_literal
@@ -647,7 +709,7 @@ should only be used in that context. C<search_literal> is a convenience
 method. It is equivalent to calling C<< $schema->search(\[]) >>, but if you
 want to ensure columns are bound correctly, use L</search>.
 
-See L<DBIx::Class::Manual::Cookbook/Searching> and
+See L<DBIx::Class::Manual::Cookbook/SEARCHING> and
 L<DBIx::Class::Manual::FAQ/Searching> for searching techniques that do not
 require C<search_literal>.
 
@@ -1212,8 +1274,6 @@ sub slice {
   $attrs->{offset} += $min;
   $attrs->{rows} = ($max ? ($max - $min + 1) : 1);
   return $self->search(undef, $attrs);
-  #my $slice = (ref $self)->new($self->result_source, $attrs);
-  #return (wantarray ? $slice->all : $slice);
 }
 
 =head2 next
@@ -1352,14 +1412,14 @@ sub _construct_results {
   return undef unless @{$rows||[]};
 
   # sanity check - people are too clever for their own good
-  if ($attrs->{collapse} and my $aliastypes = $attrs->{_sqlmaker_select_args}[3]{_aliastypes} ) {
+  if ($attrs->{collapse} and my $aliastypes = $attrs->{_last_sqlmaker_alias_map} ) {
 
     my $multiplied_selectors;
     for my $sel_alias ( grep { $_ ne $attrs->{alias} } keys %{ $aliastypes->{selecting} } ) {
       if (
         $aliastypes->{multiplying}{$sel_alias}
           or
-        scalar grep { $aliastypes->{multiplying}{(values %$_)[0]} } @{ $aliastypes->{selecting}{$sel_alias}{-parents} }
+        $aliastypes->{premultiplied}{$sel_alias}
       ) {
         $multiplied_selectors->{$_} = 1 for values %{$aliastypes->{selecting}{$sel_alias}{-seen_columns}}
       }
@@ -1729,16 +1789,14 @@ sub _count_subq_rs {
         $sql_maker->{name_sep} = '';
       }
 
-      $sql_maker->clear_renderer;
-      $sql_maker->clear_converter;
+      # delete local is 5.12+
+      local @{$sql_maker}{qw(renderer converter)};
+      delete @{$sql_maker}{qw(renderer converter)};
 
       my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep);
 
       my $having_sql = $sql_maker->_render_sqla(where => $attrs->{having});
 
-      $sql_maker->clear_renderer;
-      $sql_maker->clear_converter;
-
       my %seen_having;
 
       # search for both a proper quoted qualified string, for a naive unquoted scalarref
@@ -1916,7 +1974,7 @@ sub _rs_update_delete {
   if (!$needs_subq and @{$attrs->{from}} > 1) {
 
     ($attrs->{from}, $join_classifications) =
-      $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $self->{cond}, $attrs);
+      $storage->_prune_unused_joins ($attrs);
 
     # any non-pruneable non-local restricting joins imply subq
     $needs_subq = defined List::Util::first { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} };
@@ -1967,14 +2025,19 @@ sub _rs_update_delete {
     my $subrs = (ref $self)->new($rsrc, $attrs);
 
     if (@$idcols == 1) {
-      $cond = { $idcols->[0] => { -in => $subrs->as_query } };
+      $cond = { $idcols->[0] => { -in => \$subrs->_as_select_dq } };
     }
     elsif ($storage->_use_multicolumn_in) {
       # no syntax for calling this properly yet
       # !!! EXPERIMENTAL API !!! WILL CHANGE !!!
-      $cond = $storage->sql_maker->_where_op_multicolumn_in (
-        $idcols, # how do I convey a list of idents...? can binds reside on lhs?
-        $subrs->as_query
+      my $left = $storage->sql_maker->_render_sqla(select_select => $idcols);
+      $left =~ s/^SELECT //i;
+      my $right = $storage->sql_maker
+                          ->converter
+                          ->_literal_to_dq(${$subrs->as_query});
+      $cond = \Operator(
+        { 'SQL.Naive' => 'in' },
+        [ Literal(SQL => "( $left )"), $right ],
       ),
     }
     else {
@@ -1984,6 +2047,8 @@ sub _rs_update_delete {
       if (
         $existing_group_by
           or
+        # we do not need to check pre-multipliers, since if the premulti is there, its
+        # parent (who is multi) will be there too
         keys %{ $join_classifications->{multiplying} || {} }
       ) {
         # make sure if there is a supplied group_by it matches the columns compiled above
@@ -2327,6 +2392,11 @@ sub populate {
           $rel,
         );
 
+        if (ref($related) eq 'REF' and ref($$related) eq 'HASH') {
+          $related = $self->result_source
+                          ->_extract_fixed_values_for($$related, $rel);
+        }
+
         my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
         my @populate = map { {%$_, %$related} } @rows_to_add;
 
@@ -2336,7 +2406,6 @@ sub populate {
   }
 }
 
-
 # populate() arguments went over several incarnations
 # What we ultimately support is AoH
 sub _normalize_populate_args {
@@ -2501,16 +2570,7 @@ sub _merge_with_rscond {
   if (! defined $self->{cond}) {
     # just massage $data below
   }
-  elsif ($self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
-    %new_data = %{ $self->{attrs}{related_objects} || {} };  # nothing might have been inserted yet
-    @cols_from_relations = keys %new_data;
-  }
-  elsif (ref $self->{cond} ne 'HASH') {
-    $self->throw_exception(
-      "Can't abstract implicit construct, resultset condition not a hash"
-    );
-  }
-  else {
+  elsif (ref $self->{cond} eq 'HASH') {
     # precedence must be given to passed values over values inherited from
     # the cond, so the order here is important.
     my $collapsed_cond = $self->_collapse_cond($self->{cond});
@@ -2532,6 +2592,23 @@ sub _merge_with_rscond {
       }
     }
   }
+  elsif (ref $self->{cond} eq 'REF' and ref ${$self->{cond}} eq 'HASH') {
+    if ((${$self->{cond}})->{'DBIx::Class::ResultSource.UNRESOLVABLE'}) {
+      %new_data = %{ $self->{attrs}{related_objects} || {} };  # nothing might have been inserted yet
+      @cols_from_relations = keys %new_data;
+    } else {
+      %new_data = %{$self->_remove_alias(
+        $self->result_source
+             ->_extract_fixed_values_for(${$self->{cond}}),
+        $alias
+      )};
+    }
+  }
+  else {
+    $self->throw_exception(
+      "Can't abstract implicit construct, resultset condition not a hash"
+    );
+  }
 
   %new_data = (
     %new_data,
@@ -2674,11 +2751,22 @@ sub as_query {
     $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs
   );
 
-  $self->{_attrs}{_sqlmaker_select_args} = $attrs->{_sqlmaker_select_args};
-
   $aq;
 }
 
+sub _as_select_dq {
+  my $self = shift;
+  my $attrs = { %{ $self->_resolved_attrs } };
+  my $storage = $self->result_source->storage;
+  my (undef, $ident, @args) = $storage->_select_args(
+    $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs
+  );
+  $ident = $ident->from if blessed($ident);
+  $storage->sql_maker->converter->_select_to_dq(
+    $ident, @args
+  );
+}
+
 =head2 find_or_new
 
 =over 4
@@ -3439,6 +3527,9 @@ sub _resolved_attrs {
   my $source = $self->result_source;
   my $alias  = $attrs->{alias};
 
+  $self->throw_exception("Specifying distinct => 1 in conjunction with collapse => 1 is unsupported")
+    if $attrs->{collapse} and $attrs->{distinct};
+
   # default selection list
   $attrs->{columns} = [ $source->columns ]
     unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/;
@@ -3528,7 +3619,7 @@ sub _resolved_attrs {
         $source->_resolve_join(
           $join,
           $alias,
-          { %{ $attrs->{seen_join} || {} } },
+          ($attrs->{seen_join} = { %{ $attrs->{seen_join} || {} } }),
           ( $attrs->{seen_join} && keys %{$attrs->{seen_join}})
             ? $attrs->{from}[-1][0]{-join_path}
             : []
@@ -3549,22 +3640,9 @@ sub _resolved_attrs {
     $attrs->{group_by} = [ $attrs->{group_by} ];
   }
 
-  # generate the distinct induced group_by early, as prefetch will be carried via a
-  # subquery (since a group_by is present)
-  if (delete $attrs->{distinct}) {
-    if ($attrs->{group_by}) {
-      carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
-    }
-    else {
-      $attrs->{_grouped_by_distinct} = 1;
-      # distinct affects only the main selection part, not what prefetch may
-      # add below.
-      $attrs->{group_by} = $source->storage->_group_over_selection($attrs);
-    }
-  }
 
   # generate selections based on the prefetch helper
-  my $prefetch;
+  my ($prefetch, @prefetch_select, @prefetch_as);
   $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} )
     if defined $attrs->{prefetch};
 
@@ -3573,6 +3651,9 @@ sub _resolved_attrs {
     $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}")
       if $attrs->{_dark_selector};
 
+    $self->throw_exception("Specifying prefetch in conjunction with an explicit collapse => 0 is unsupported")
+      if defined $attrs->{collapse} and ! $attrs->{collapse};
+
     $attrs->{collapse} = 1;
 
     # this is a separate structure (we don't look in {from} directly)
@@ -3598,12 +3679,9 @@ sub _resolved_attrs {
 
     my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map );
 
-    push @{ $attrs->{select} }, (map { $_->[0] } @prefetch);
-    push @{ $attrs->{as} }, (map { $_->[1] } @prefetch);
-  }
-
-  if ( List::Util::first { $_ =~ /\./ } @{$attrs->{as}} ) {
-    $attrs->{_related_results_construction} = 1;
+    # save these for after distinct resolution
+    @prefetch_select = map { $_->[0] } @prefetch;
+    @prefetch_as = map { $_->[1] } @prefetch;
   }
 
   # run through the resulting joinstructure (starting from our current slot)
@@ -3655,6 +3733,34 @@ sub _resolved_attrs {
     }
   }
 
+  # generate the distinct induced group_by before injecting the prefetched select/as parts
+  if (delete $attrs->{distinct}) {
+    if ($attrs->{group_by}) {
+      carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
+    }
+    else {
+      $attrs->{_grouped_by_distinct} = 1;
+      # distinct affects only the main selection part, not what prefetch may add below
+      ($attrs->{group_by}, my $new_order) = $source->storage->_group_over_selection($attrs);
+
+      # FIXME possibly ignore a rewritten order_by (may turn out to be an issue)
+      # The thinking is: if we are collapsing the subquerying prefetch engine will
+      # rip stuff apart for us anyway, and we do not want to have a potentially
+      # function-converted external order_by
+      # ( there is an explicit if ( collapse && _grouped_by_distinct ) check in DBIHacks )
+      $attrs->{order_by} = $new_order unless $attrs->{collapse};
+    }
+  }
+
+  # inject prefetch-bound selection (if any)
+  push @{$attrs->{select}}, @prefetch_select;
+  push @{$attrs->{as}}, @prefetch_as;
+
+  # whether we can get away with the dumbest (possibly DBI-internal) collapser
+  if ( List::Util::first { $_ =~ /\./ } @{$attrs->{as}} ) {
+    $attrs->{_related_results_construction} = 1;
+  }
+
   # if both page and offset are specified, produce a combined offset
   # even though it doesn't make much sense, this is what pre 081xx has
   # been doing
@@ -4447,8 +4553,17 @@ or with an in-place function in which case literal SQL is required:
 
 =back
 
-Set to 1 to group by all columns. If the resultset already has a group_by
-attribute, this setting is ignored and an appropriate warning is issued.
+Set to 1 to automatically generate a L</group_by> clause based on the selection
+(including intelligent handling of L</order_by> contents). Note that the group
+criteria calculation takes place over the B<final> selection. This includes
+any L</+columns>, L</+select> or L</order_by> additions in subsequent
+L</search> calls, and standalone columns selected via
+L<DBIx::Class::ResultSetColumn> (L</get_column>). A notable exception are the
+extra selections specified via L</prefetch> - such selections are explicitly
+excluded from group criteria calculations.
+
+If the final ResultSet also explicitly defines a L</group_by> attribute, this
+setting is ignored and an appropriate warning is issued.
 
 =head2 where