And lose yet another dependency: List::Util (yes, I know it's core)
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSet.pm
index defbe9a..b51e05c 100644 (file)
@@ -8,13 +8,11 @@ use DBIx::Class::ResultSetColumn;
 use DBIx::Class::ResultClass::HashRefInflator;
 use Scalar::Util qw/blessed weaken reftype/;
 use DBIx::Class::_Util qw(
+  dbic_internal_try dump_value
   fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION
 );
 use Try::Tiny;
 
-# not importing first() as it will clash with our own method
-use List::Util ();
-
 BEGIN {
   # De-duplication in _merge_attr() is disabled, but left in for reference
   # (the merger is used for other things that ought not to be de-duped)
@@ -442,7 +440,7 @@ sub search_rs {
     $call_cond = shift;
   }
   # fish out attrs in the ($condref, $attr) case
-  elsif (@_ == 2 and ( ! defined $_[0] or (ref $_[0]) ne '') ) {
+  elsif (@_ == 2 and ( ! defined $_[0] or length ref $_[0] ) ) {
     ($call_cond, $call_attrs) = @_;
   }
   elsif (@_ % 2) {
@@ -456,7 +454,7 @@ sub search_rs {
     for my $i (0 .. $#_) {
       next if $i % 2;
       $self->throw_exception ('All keys in condition key/value pairs must be plain scalars')
-        if (! defined $_[$i] or ref $_[$i] ne '');
+        if (! defined $_[$i] or length ref $_[$i] );
     }
 
     $call_cond = { @_ };
@@ -465,7 +463,7 @@ sub search_rs {
   # see if we can keep the cache (no $rs changes)
   my $cache;
   my %safe = (alias => 1, cache => 1);
-  if ( ! List::Util::first { !$safe{$_} } keys %$call_attrs and (
+  if ( ! grep { !$safe{$_} } keys %$call_attrs and (
     ! defined $call_cond
       or
     ref $call_cond eq 'HASH' && ! keys %$call_cond
@@ -489,9 +487,8 @@ sub search_rs {
     my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/;
 
     # reset the current selector list if new selectors are supplied
-    if (List::Util::first { exists $call_attrs->{$_} } qw/columns cols select as/) {
-      delete @{$old_attrs}{(@selector_attrs, '_dark_selector')};
-    }
+    delete @{$old_attrs}{(@selector_attrs, '_dark_selector')}
+      if grep { exists $call_attrs->{$_} } qw(columns cols select as);
 
     # Normalize the new selector list (operates on the passed-in attr structure)
     # Need to do it on every chain instead of only once on _resolved_attrs, in
@@ -553,7 +550,6 @@ sub search_rs {
   return $rs;
 }
 
-my $dark_sel_dumper;
 sub _normalize_selection {
   my ($self, $attrs) = @_;
 
@@ -618,11 +614,10 @@ sub _normalize_selection {
           else {
             $attrs->{_dark_selector} = {
               plus_stage => $pref,
-              string => ($dark_sel_dumper ||= do {
-                  require Data::Dumper::Concise;
-                  Data::Dumper::Concise::DumperObject()->Indent(0);
-                })->Values([$_])->Dump
-              ,
+              string => do {
+                local $Data::Dumper::Indent = 0;
+                dump_value $_;
+              },
             };
             last SELECTOR;
           }
@@ -878,7 +873,7 @@ sub find {
         join "\x00", sort $rsrc->unique_constraint_columns($c_name)
       }++;
 
-      try {
+      dbic_internal_try {
         push @unique_queries, $self->_qualify_cond_columns(
           $self->result_source->_minimal_valueset_satisfying_constraint(
             constraint_name => $c_name,
@@ -1414,7 +1409,7 @@ sub _construct_results {
           : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows'
         ),
         ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) )
-      );
+      ) . '; 1' or die;
     }
   }
   else {
@@ -1424,60 +1419,30 @@ sub _construct_results {
       :                                           'classic_nonpruning'
     ;
 
-    # $args and $attrs to _mk_row_parser are separated to delineate what is
-    # core collapser stuff and what is dbic $rs specific
-    @{$self->{_row_parser}{$parser_type}}{qw(cref nullcheck)} = $rsrc->_mk_row_parser({
-      eval => 1,
-      inflate_map => $infmap,
-      collapse => $attrs->{collapse},
-      premultiplied => $attrs->{_main_source_premultiplied},
-      hri_style => $self->{_result_inflator}{is_hri},
-      prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row},
-    }, $attrs) unless $self->{_row_parser}{$parser_type}{cref};
-
-    # column_info metadata historically hasn't been too reliable.
-    # We need to start fixing this somehow (the collapse resolver
-    # can't work without it). Add an explicit check for the *main*
-    # result, hopefully this will gradually weed out such errors
-    #
-    # FIXME - this is a temporary kludge that reduces performance
-    # It is however necessary for the time being
-    my ($unrolled_non_null_cols_to_check, $err);
-
-    if (my $check_non_null_cols = $self->{_row_parser}{$parser_type}{nullcheck} ) {
-
-      $err =
-        'Collapse aborted due to invalid ResultSource metadata - the following '
-      . 'selections are declared non-nullable but NULLs were retrieved: '
-      ;
-
-      my @violating_idx;
-      COL: for my $i (@$check_non_null_cols) {
-        ! defined $_->[$i] and push @violating_idx, $i and next COL for @$rows;
-      }
+    unless( $self->{_row_parser}{$parser_type}{cref} ) {
 
-      $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) )
-        if @violating_idx;
+      # $args and $attrs to _mk_row_parser are separated to delineate what is
+      # core collapser stuff and what is dbic $rs specific
+      $self->{_row_parser}{$parser_type}{src} = $rsrc->_mk_row_parser({
+        inflate_map => $infmap,
+        collapse => $attrs->{collapse},
+        premultiplied => $attrs->{_main_source_premultiplied},
+        hri_style => $self->{_result_inflator}{is_hri},
+        prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row},
+      }, $attrs);
 
-      $unrolled_non_null_cols_to_check = join (',', @$check_non_null_cols);
+      $self->{_row_parser}{$parser_type}{cref} = do {
+        package # hide form PAUSE
+          DBIx::Class::__GENERATED_ROW_PARSER__;
 
-      utf8::upgrade($unrolled_non_null_cols_to_check)
-        if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE;
+        eval $self->{_row_parser}{$parser_type}{src};
+      } || die $@;
     }
 
-    my $next_cref =
-      ($did_fetch_all or ! $attrs->{collapse})  ? undef
-    : defined $unrolled_non_null_cols_to_check  ? eval sprintf <<'EOS', $unrolled_non_null_cols_to_check
-sub {
-  # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
-  my @r = $cursor->next or return;
-  if (my @violating_idx = grep { ! defined $r[$_] } (%s) ) {
-    $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) )
-  }
-  \@r
-}
-EOS
-    : sub {
+    # this needs to close over the *current* cursor, hence why it is not cached above
+    my $next_cref = ($did_fetch_all or ! $attrs->{collapse})
+      ? undef
+      : sub {
         # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
         my @r = $cursor->next or return;
         \@r
@@ -1486,9 +1451,25 @@ EOS
 
     $self->{_row_parser}{$parser_type}{cref}->(
       $rows,
-      $next_cref ? ( $next_cref, $self->{_stashed_rows} = [] ) : (),
+      $next_cref,
+      ( $self->{_stashed_rows} = [] ),
+      ( my $null_violations = {} ),
     );
 
+    $self->throw_exception(
+      'Collapse aborted - the following columns are declared (or defaulted to) '
+    . 'non-nullable within DBIC but NULLs were retrieved from storage: '
+    . join( ', ', map { "'$infmap->[$_]'" } sort { $a <=> $b } keys %$null_violations )
+    . ' within data row ' . dump_value({
+      map {
+        $infmap->[$_] =>
+          ( ! defined $self->{_stashed_rows}[0][$_] or length $self->{_stashed_rows}[0][$_] < 50 )
+            ? $self->{_stashed_rows}[0][$_]
+            : substr( $self->{_stashed_rows}[0][$_], 0, 50 ) . '...'
+      } 0 .. $#{$self->{_stashed_rows}[0]}
+    })
+    ) if keys %$null_violations;
+
     # simple in-place substitution, does not regrow $rows
     if ($self->{_result_inflator}{is_core_row}) {
       $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows
@@ -1903,7 +1884,7 @@ sub _rs_update_delete {
       $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} || {} };
+    $needs_subq = grep { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} };
   }
 
   # check if the head is composite (by now all joins are thrown out unless $needs_subq)
@@ -3220,10 +3201,16 @@ Returns a related resultset for the supplied relationship name.
 =cut
 
 sub related_resultset {
-  my ($self, $rel) = @_;
+  $_[0]->throw_exception(
+    'Extra arguments to $rs->related_resultset() were always quietly '
+  . 'discarded without consideration, you need to switch to '
+  . '...->related_resultset( $relname )->search_rs( $search, $args ) instead.'
+  ) if @_ > 2;
 
-  return $self->{related_resultsets}{$rel}
-    if defined $self->{related_resultsets}{$rel};
+  return $_[0]->{related_resultsets}{$_[1]}
+    if defined $_[0]->{related_resultsets}{$_[1]};
+
+  my ($self, $rel) = @_;
 
   return $self->{related_resultsets}{$rel} = do {
     my $rsrc = $self->result_source;
@@ -3236,22 +3223,25 @@ sub related_resultset {
 
     my $attrs = $self->_chain_relationship($rel);
 
-    my $join_count = $attrs->{seen_join}{$rel};
+    my $storage = $rsrc->schema->storage;
 
-    my $alias = $self->result_source->storage
-        ->relname_to_table_alias($rel, $join_count);
+    # Previously this atribute was deleted (instead of being set as it is now)
+    # Doing so seems to be harmless in all available test permutations
+    # See also 01d59a6a6 and mst's comment below
+    #
+    $attrs->{alias} = $storage->relname_to_table_alias(
+      $rel,
+      $attrs->{seen_join}{$rel}
+    );
 
     # since this is search_related, and we already slid the select window inwards
     # (the select/as attrs were deleted in the beginning), we need to flip all
     # left joins to inner, so we get the expected results
     # read the comment on top of the actual function to see what this does
-    $attrs->{from} = $rsrc->schema->storage->_inner_join_to_node ($attrs->{from}, $alias);
-
+    $attrs->{from} = $storage->_inner_join_to_node( $attrs->{from}, $attrs->{alias} );
 
     #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi
-    delete @{$attrs}{qw(result_class alias)};
-
-    my $rel_source = $rsrc->related_source($rel);
+    delete $attrs->{result_class};
 
     my $new = do {
 
@@ -3260,16 +3250,19 @@ sub related_resultset {
       # source you need to know what alias it's -going- to have for things
       # to work sanely (e.g. RestrictWithObject wants to be able to add
       # extra query restrictions, and these may need to be $alias.)
-
-      my $rel_attrs = $rel_source->resultset_attributes;
-      local $rel_attrs->{alias} = $alias;
-
-      $rel_source->resultset
-                 ->search_rs(
-                     undef, {
-                       %$attrs,
-                       where => $attrs->{where},
-                   });
+      #                                       -- mst ~ 2007 (01d59a6a6)
+      #
+      # FIXME - this seems to be no longer neccessary (perhaps due to the
+      # advances in relcond resolution. Testing DBIC::S::RWO and its only
+      # dependent (as of Jun 2015 ) does not yield any difference with or
+      # without this line. Nevertheless keep it as is for now, to minimize
+      # churn, there is enough potential for breakage in 0.0829xx as it is
+      #                                       -- ribasushi Jun 2015
+      #
+      my $rel_source = $rsrc->related_source($rel);
+      local $rel_source->resultset_attributes->{alias} = $attrs->{alias};
+
+      $rel_source->resultset->search_rs( undef, $attrs );
     };
 
     if (my $cache = $self->get_cache) {
@@ -3519,9 +3512,22 @@ sub _resolved_attrs {
   $self->throw_exception("Specifying distinct => 1 in conjunction with collapse => 1 is unsupported")
     if $attrs->{collapse} and $attrs->{distinct};
 
+
+  # Sanity check the paging attributes
+  # SQLMaker does it too, but in case of a software_limit we'll never get there
+  if (defined $attrs->{offset}) {
+    $self->throw_exception('A supplied offset attribute must be a non-negative integer')
+      if ( $attrs->{offset} =~ /[^0-9]/ or $attrs->{offset} < 0 );
+  }
+  if (defined $attrs->{rows}) {
+    $self->throw_exception("The rows attribute must be a positive integer if present")
+      if ( $attrs->{rows} =~ /[^0-9]/ or $attrs->{rows} <= 0 );
+  }
+
+
   # default selection list
   $attrs->{columns} = [ $source->columns ]
-    unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/;
+    unless grep { exists $attrs->{$_} } qw/columns cols select as/;
 
   # merge selectors together
   for (qw/columns select as/) {
@@ -3682,7 +3688,7 @@ sub _resolved_attrs {
         if (
           ! $attrs->{_main_source_premultiplied}
             and
-          ! List::Util::first { ! $_->[0]{-is_single} } @fromlist
+          ! grep { ! $_->[0]{-is_single} } @fromlist
         ) {
           $attrs->{collapse} = 0;
         }
@@ -3912,7 +3918,7 @@ sub _merge_joinpref_attr {
           },
           ARRAY => sub {
             return $_[1] if !defined $_[0];
-            return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]};
+            return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]};
             return [$_[0], @{$_[1]}]
           },
           HASH  => sub {
@@ -3925,7 +3931,7 @@ sub _merge_joinpref_attr {
         ARRAY => {
           SCALAR => sub {
             return $_[0] if !defined $_[1];
-            return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]};
+            return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]};
             return [@{$_[0]}, $_[1]]
           },
           ARRAY => sub {
@@ -3938,7 +3944,7 @@ sub _merge_joinpref_attr {
           HASH => sub {
             return [ $_[1] ] if ! @{$_[0]};
             return $_[0] if !keys %{$_[1]};
-            return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]};
+            return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]};
             return [ @{$_[0]}, $_[1] ];
           },
         },
@@ -3953,7 +3959,7 @@ sub _merge_joinpref_attr {
             return [] if !keys %{$_[0]} and !@{$_[1]};
             return [ $_[0] ] if !@{$_[1]};
             return $_[1] if !keys %{$_[0]};
-            return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]};
+            return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]};
             return [ $_[0], @{$_[1]} ];
           },
           HASH => sub {
@@ -4620,7 +4626,7 @@ revisit rows in your ResultSet:
     ... do stuff ...
   }
 
-  $rs->first; # without cache, this would issue a query
+  $resultset->first; # without cache, this would issue a query
 
 By default, searches are not cached.