From: Peter Rabbitson Date: Sat, 5 Oct 2013 08:14:38 +0000 (+0200) Subject: Fix and guard against erroneous use of list context in internal DBIC code X-Git-Tag: v0.08260~130 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a9da9b6a;p=dbsrgits%2FDBIx-Class.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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;