Fix and guard against erroneous use of list context in internal DBIC code

This situation is dangerous in case the end-user employs something like
DBIx::Class::Helper::ResultSet::IgnoreWantarray

Besides the trivial fix in ::Row::copy, this commit introduces the
DBIC_ASSERT_NO_INTERNAL_WANTARRAY=1 mechanism (which will be
automatically picked up and engaged by our CI due to eed5492f). As a
bonus the check is usable on DBIC dependencies as well.

diff --git a/Changes b/Changes
index ea0bdfc..031fddd 100644 (file)
--- a/Changes
+++ b/Changes
@@ -11,6 +11,7 @@ Revision history for DBIx::Class
           SQLite DDL (it is one of the few producers *NOT* quoting by default)
         - Back out self-cleaning from DBIx::Class::Carp for the time being
           (as a side effect fixes RT#86267)
+        - Fix incorrect internal use of implicit list context in copy()
         - Tests no longer fail if $ENV{DBI_DSN} is set
         - Throw clearer exception on ->new_related() with a non-existent
           relationship.

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index c14a6af..38fde7a 100644 (file)
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -40,6 +40,8 @@ BEGIN {
       # otherwise we are good
                                                                                     : 0
     ,
+
+    ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0,
   };
 
   if ($] < 5.009_005) {

diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm
index c48e80f..3a12f28 100644 (file)
--- a/lib/DBIx/Class/Relationship/Accessor.pm
+++ b/lib/DBIx/Class/Relationship/Accessor.pm
@@ -5,6 +5,7 @@ use strict;
 use warnings;
 use Sub::Name;
 use DBIx::Class::Carp;
+use DBIx::Class::_Util 'fail_on_internal_wantarray';
 use namespace::clean;
 
 our %_pod_inherit_config =
@@ -80,7 +81,10 @@ sub add_relationship_accessor {
       }
     );
   } elsif ($acc_type eq 'multi') {
-    $meth{$rel} = sub { shift->search_related($rel, @_) };
+    $meth{$rel} = sub {
+      DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and wantarray and my $sog = fail_on_internal_wantarray($_[0]);
+      shift->search_related($rel, @_)
+    };
     $meth{"${rel}_rs"} = sub { shift->search_related_rs($rel, @_) };
     $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); };
   } else {

diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm
index a6bedc5..07f89c2 100644 (file)
--- a/lib/DBIx/Class/Relationship/ManyToMany.pm
+++ b/lib/DBIx/Class/Relationship/ManyToMany.pm
@@ -5,9 +5,9 @@ use strict;
 use warnings;
 
 use DBIx::Class::Carp;
-use Sub::Name qw/subname/;
-use Scalar::Util qw/blessed/;
-
+use Sub::Name 'subname';
+use Scalar::Util 'blessed';
+use DBIx::Class::_Util 'fail_on_internal_wantarray';
 use namespace::clean;
 
 our %_pod_inherit_config =
@@ -72,6 +72,7 @@ EOW
 
     my $meth_name = join '::', $class, $meth;
     *$meth_name = subname $meth_name, sub {
+      DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and wantarray and my $sog = fail_on_internal_wantarray($_[0]);
       my $self = shift;
       my $rs = $self->$rs_meth( @_ );
       return (wantarray ? $rs->all : $rs);

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index f7dedfb..35dfaf5 100644 (file)
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -6,6 +6,7 @@ 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
 
@@ -327,6 +328,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) {
@@ -1211,8 +1213,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

diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm
index ed29a44..40cf73e 100644 (file)
--- a/lib/DBIx/Class/ResultSetColumn.pm
+++ b/lib/DBIx/Class/ResultSetColumn.pm
@@ -5,6 +5,7 @@ use warnings;
 
 use base 'DBIx::Class';
 use DBIx::Class::Carp;
+use DBIx::Class::_Util 'fail_on_internal_wantarray';
 use namespace::clean;
 
 # not importing first() as it will clash with our own method
@@ -401,6 +402,7 @@ sub func {
   my $cursor = $self->func_rs($function)->cursor;
 
   if( wantarray ) {
+    DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray($self);
     return map { $_->[ 0 ] } $cursor->all;
   }
 

diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm
index c757b2e..000498a 100644 (file)
--- a/lib/DBIx/Class/Row.pm
+++ b/lib/DBIx/Class/Row.pm
@@ -1144,7 +1144,7 @@ sub copy {
     );
 
     my $copied = $relnames_copied->{ $rel_info->{source} } ||= {};
-    foreach my $related ($self->search_related($relname)) {
+    foreach my $related ($self->search_related($relname)->all) {
       my $id_str = join("\0", $related->id);
       next if $copied->{$id_str};
       $copied->{$id_str} = 1;

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index d4760bc..e6cf2a9 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -7,9 +7,10 @@ use strict;
 use constant SPURIOUS_VERSION_CHECK_WARNINGS => ($] < 5.010 ? 1 : 0);
 
 use Carp;
+use Scalar::Util qw(refaddr weaken);
 
 use base 'Exporter';
-our @EXPORT_OK = qw(modver_gt_or_eq);
+our @EXPORT_OK = qw(modver_gt_or_eq fail_on_internal_wantarray);
 
 sub modver_gt_or_eq {
   my ($mod, $ver) = @_;
@@ -31,4 +32,47 @@ sub modver_gt_or_eq {
   eval { $mod->VERSION($ver) } ? 1 : 0;
 }
 
+{
+  my $list_ctx_ok_stack_marker;
+
+  sub fail_on_internal_wantarray {
+    return if $list_ctx_ok_stack_marker;
+
+    if (! defined wantarray) {
+      croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
+    }
+
+    my $cf = 1;
+    while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?:
+
+      # these are public API parts that alter behavior on wantarray
+      search | search_related | slice | search_literal
+
+        |
+
+      # these are explicitly prefixed, since we only recognize them as valid
+      # escapes when they come from the guts of CDBICompat
+      CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
+
+    ) $/x ) {
+      $cf++;
+    }
+
+    if (
+      (caller($cf))[0] =~ /^(?:DBIx::Class|DBICx::)/
+    ) {
+      my $obj = shift;
+
+      DBIx::Class::Exception->throw( sprintf (
+        "Improper use of %s(0x%x) instance in list context at %s line %d\n\n\tStacktrace starts",
+        ref($obj), refaddr($obj), (caller($cf))[1,2]
+      ), 'with_stacktrace');
+    }
+
+    my $mark = [];
+    weaken ( $list_ctx_ok_stack_marker = $mark );
+    $mark;
+  }
+}
+
 1;