From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 7 Mar 2013 12:12:58 +0000 (+0100)
Subject: Warn in case of iterative collapse being upgraded to an eager cursor slurp
X-Git-Tag: v0.08242~5
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=69e99ee63239ebcdd53f4aaa05c5cea5a54ed624;p=dbsrgits%2FDBIx-Class.git

Warn in case of iterative collapse being upgraded to an eager cursor slurp
---

diff --git a/Changes b/Changes
index fb6c0e6..99bd20d 100644
--- a/Changes
+++ b/Changes
@@ -8,7 +8,8 @@ Revision history for DBIx::Class
         - Scale back validation of the 'as' attribute - in the field
           there are legitimate-ish uses of a inflating into an apparently
           invalid relationship graph
-
+        - Warn in case of iterative collapse being upgraded to an eager
+          cursor slurp
 
 0.08209 2013-03-01 12:56 (UTC)
     * New Features / Changes
diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index f2ab80b..2582fe2 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -1277,9 +1277,17 @@ sub _construct_results {
   my $rsrc = $self->result_source;
   my $attrs = $self->_resolved_attrs;
 
-  if (!$fetch_all and ! $attrs->{order_by} and $attrs->{collapse}) {
+  if (
+    ! $fetch_all
+      and
+    ! $attrs->{order_by}
+      and
+    $attrs->{collapse}
+      and
+    my @pcols = $rsrc->primary_columns
+  ) {
     # default order for collapsing unless the user asked for something
-    $attrs->{order_by} = [ map { join '.', $attrs->{alias}, $_} $rsrc->primary_columns ];
+    $attrs->{order_by} = [ map { join '.', $attrs->{alias}, $_} @pcols ];
     $attrs->{_ordered_for_collapse} = 1;
     $attrs->{_order_is_artificial} = 1;
   }
@@ -1291,6 +1299,8 @@ sub _construct_results {
   # a surprising amount actually
   my $rows = delete $self->{_stashed_rows};
 
+  my $did_fetch_all = $fetch_all;
+
   if ($fetch_all) {
     # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
     $rows = [ ($rows ? @$rows : ()), $cursor->all ];
@@ -1327,7 +1337,7 @@ sub _construct_results {
     } unless defined $attrs->{_ordered_for_collapse};
 
     if (! $attrs->{_ordered_for_collapse}) {
-      $fetch_all = 1;
+      $did_fetch_all = 1;
 
       # instead of looping over ->next, use ->all in stealth mode
       # *without* calling a ->reset afterwards
@@ -1339,7 +1349,7 @@ sub _construct_results {
     }
   }
 
-  if (! $fetch_all and ! @{$rows||[]} ) {
+  if (! $did_fetch_all and ! @{$rows||[]} ) {
     # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
     if (scalar (my @r = $cursor->next) ) {
       $rows = [ \@r ];
@@ -1349,7 +1359,7 @@ sub _construct_results {
   return undef unless @{$rows||[]};
 
   my @extra_collapser_args;
-  if ($attrs->{collapse} and ! $fetch_all ) {
+  if ($attrs->{collapse} and ! $did_fetch_all ) {
 
     @extra_collapser_args = (
       # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref
@@ -1440,6 +1450,16 @@ sub _construct_results {
     $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows;
   }
 
+  # The @$rows check seems odd at first - why wouldn't we want to warn
+  # regardless? The issue is things like find() etc, where the user
+  # *knows* only one result will come back. In these cases the ->all
+  # is not a pessimization, but rather something we actually want
+  carp_unique(
+    'Unable to properly collapse has_many results in iterator mode due '
+  . 'to order criteria - performed an eager cursor slurp underneath. '
+  . 'Consider using ->all() instead'
+  ) if ( ! $fetch_all and @$rows > 1 );
+
   return $rows;
 }
 
diff --git a/t/prefetch/grouped.t b/t/prefetch/grouped.t
index 27d3865..40ac923 100644
--- a/t/prefetch/grouped.t
+++ b/t/prefetch/grouped.t
@@ -186,7 +186,7 @@ for ($cd_rs->all) {
   );
 
   is ($most_tracks_rs->count, 2, 'Limit works');
-  my $top_cd = $most_tracks_rs->first;
+  my ($top_cd) = $most_tracks_rs->all;
   is ($top_cd->id, 2, 'Correct cd fetched on top'); # 2 because of the slice(1,1) earlier
 
   my $query_cnt = 0;
diff --git a/t/prefetch/incomplete.t b/t/prefetch/incomplete.t
index cf6c514..8840c1d 100644
--- a/t/prefetch/incomplete.t
+++ b/t/prefetch/incomplete.t
@@ -26,7 +26,7 @@ lives_ok(sub {
   );
 
   is ($rs->count, 2, 'Correct number of collapsed artists');
-  my $we_are_goth = $rs->first;
+  my ($we_are_goth) = $rs->all;
   is ($we_are_goth->name, 'We Are Goth', 'Correct first artist');
   is ($we_are_goth->cds->count, 1, 'Correct number of CDs for first artist');
   is ($we_are_goth->cds->first->title, 'Come Be Depressed With Us', 'Correct cd for artist');
diff --git a/t/prefetch/lazy_cursor.t b/t/prefetch/lazy_cursor.t
index 5f96796..220e3c6 100644
--- a/t/prefetch/lazy_cursor.t
+++ b/t/prefetch/lazy_cursor.t
@@ -2,6 +2,7 @@ use strict;
 use warnings;
 
 use Test::More;
+use Test::Warn;
 use Test::Exception;
 use lib qw(t/lib);
 use DBICTest;
@@ -64,7 +65,11 @@ is ( ($rs->cursor->next)[0], 1, 'Cursor auto-rewound after all()');
 is ($rs->{_stashed_rows}, undef, 'Nothing else left in $rs stash');
 
 my $unordered_rs = $rs->search({}, { order_by => 'cds.title' });
-ok ($unordered_rs->next, 'got row 1');
+
+warnings_exist {
+  ok ($unordered_rs->next, 'got row 1');
+} qr/performed an eager cursor slurp underneath/, 'Warned on auto-eager cursor';
+
 is_deeply ([$unordered_rs->cursor->next], [], 'Nothing left on cursor, eager slurp');
 ok ($unordered_rs->next, "got row $_")  for (2 .. $initial_artists_cnt + 3);
 is ($unordered_rs->next, undef, 'End of RS reached');
diff --git a/t/prefetch/manual.t b/t/prefetch/manual.t
index 222fe35..c6d1f6a 100644
--- a/t/prefetch/manual.t
+++ b/t/prefetch/manual.t
@@ -3,6 +3,7 @@ use warnings;
 
 use Test::More;
 use Test::Deep;
+use Test::Warn;
 use Test::Exception;
 use lib qw(t/lib);
 use DBICTest;
@@ -186,7 +187,7 @@ cmp_deeply (
 );
 
 TODO: {
-  my $row = $rs->next;
+  my ($row) = $rs->all;
   local $TODO = 'Something is wrong with filter type rels, they throw on incomplete objects >.<';
 
   lives_ok {
@@ -198,9 +199,6 @@ TODO: {
   } 'no exception';
 }
 
-is ($rs->cursor->next, undef, 'cursor exhausted');
-
-
 TODO: {
 local $TODO = 'this does not work at all, need to promote rsattrs to an object on its own';
 # make sure has_many column redirection does not do weird stuff when collapse is requested
@@ -269,9 +267,12 @@ $schema->storage->debug (1);
 for my $use_next (0, 1) {
   my @random_cds;
   if ($use_next) {
-    while (my $o = $rs_random->next) {
-      push @random_cds, $o;
-    }
+    warnings_exist {
+      while (my $o = $rs_random->next) {
+        push @random_cds, $o;
+      }
+    } qr/performed an eager cursor slurp underneath/,
+    'Warned on auto-eager cursor';
   }
   else {
     @random_cds = $rs_random->all;