Add internal assertion guard for some indirect calls (for now only create/new)

Modeled on the idea of a9da9b6a, this one blows up when a public proxy
is called insted of the equivalent public chan of methods

This particular set of changes to create() and new() is solely an
optimisation (unlike a subsequent commit to ::ResultSourceProxy)

diff --git a/lib/DBIx/Class/Admin.pm b/lib/DBIx/Class/Admin.pm
index 4c7c6bb..003f4ae 100644 (file)
--- a/lib/DBIx/Class/Admin.pm
+++ b/lib/DBIx/Class/Admin.pm
@@ -451,7 +451,7 @@ sub insert {
   $rs ||= $self->resultset();
   $set ||= $self->set();
   my $resultset = $self->schema->resultset($rs);
-  my $obj = $resultset->create( $set );
+  my $obj = $resultset->new_result($set)->insert;
   print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$self->quiet);
 }
 

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index e81fc82..0262537 100644 (file)
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -7,7 +7,7 @@ use DBIx::Class::Carp;
 use DBIx::Class::ResultSetColumn;
 use Scalar::Util qw/blessed weaken reftype/;
 use DBIx::Class::_Util qw(
-  fail_on_internal_wantarray UNRESOLVABLE_CONDITION
+  fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION
 );
 use Try::Tiny;
 use Data::Compare (); # no imports!!! guard against insane architecture
@@ -301,7 +301,11 @@ creation B<will not work>. See also warning pertaining to L</create>.
 
 sub new {
   my $class = shift;
-  return $class->new_result(@_) if ref $class;
+
+  if (ref $class) {
+    DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
+    return $class->new_result(@_);
+  }
 
   my ($source, $attrs) = @_;
   $source = $source->resolve
@@ -2236,7 +2240,7 @@ sub populate {
   return unless @$data;
 
   if(defined wantarray) {
-    my @created = map { $self->create($_) } @$data;
+    my @created = map { $self->new_result($_)->insert } @$data;
     return wantarray ? @created : \@created;
   }
   else {
@@ -2272,7 +2276,7 @@ sub populate {
 
       foreach my $rel (@rels) {
         next unless ref $data->[$index]->{$rel} eq "HASH";
-        my $result = $self->related_resultset($rel)->create($data->[$index]->{$rel});
+        my $result = $self->related_resultset($rel)->new_result($data->[$index]->{$rel})->insert;
         my (undef, $reverse_relinfo) = %{$rsrc->reverse_relationship_info($rel)};
         my $related = $result->result_source->_resolve_condition(
           $reverse_relinfo->{cond},
@@ -2748,6 +2752,7 @@ L</new>.
 
 sub create {
   #my ($self, $col_data) = @_;
+  DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   return shift->new_result(shift)->insert;
 }
 
@@ -2830,7 +2835,7 @@ sub find_or_create {
   if (keys %$hash and my $row = $self->find($hash, $attrs) ) {
     return $row;
   }
-  return $self->create($hash);
+  return $self->new_result($hash)->insert;
 }
 
 =head2 update_or_create
@@ -2900,7 +2905,7 @@ sub update_or_create {
     return $row;
   }
 
-  return $self->create($cond);
+  return $self->new_result($cond)->insert;
 }
 
 =head2 update_or_new

diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm
index 114064a..95adc66 100644 (file)
--- a/lib/DBIx/Class/Schema/Versioned.pm
+++ b/lib/DBIx/Class/Schema/Versioned.pm
@@ -603,7 +603,7 @@ sub _on_connect
     my $vtable_compat = DBIx::Class::VersionCompat->connect(@$conn_info)->resultset('TableCompat');
     if ($self->_source_exists($vtable_compat)) {
       $self->{vschema}->deploy;
-      map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
+      map { $vtable->new_result({ installed => $_->Installed, version => $_->Version })->insert } $vtable_compat->all;
       $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
     }
   }
@@ -710,7 +710,7 @@ sub _set_db_version {
   # formatted by this new function will sort _after_ any existing 200... strings.
   my @tm = gettimeofday();
   my @dt = gmtime ($tm[0]);
-  my $o = $vtable->create({
+  my $o = $vtable->new_result({
     version => $version,
     installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f",
       $dt[5] + 1900,
@@ -721,7 +721,7 @@ sub _set_db_version {
       $dt[0],
       int($tm[1] / 1000), # convert to millisecs
     ),
-  });
+  })->insert;
 }
 
 sub _read_sql_file {

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index d43d836..5a35ab3 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -30,6 +30,8 @@ BEGIN {
 
     ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0,
 
+    ASSERT_NO_INTERNAL_INDIRECT_CALLS => $ENV{DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS} ? 1 : 0,
+
     IV_SIZE => $Config{ivsize},
 
     OS_NAME => $^O,
@@ -55,7 +57,8 @@ use List::Util qw(first);
 
 use base 'Exporter';
 our @EXPORT_OK = qw(
-  sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray
+  sigwarn_silencer modver_gt_or_eq
+  fail_on_internal_wantarray fail_on_internal_call
   refdesc refcount hrefaddr is_exception
   UNRESOLVABLE_CONDITION
 );
@@ -218,4 +221,33 @@ sub modver_gt_or_eq ($$) {
   }
 }
 
+sub fail_on_internal_call {
+  my ($fr, $argdesc);
+  {
+    package DB;
+    $fr = [ caller(1) ];
+    $argdesc = ref $DB::args[0]
+      ? DBIx::Class::_Util::refdesc($DB::args[0])
+      : undef
+    ;
+  };
+
+  if (
+    $argdesc
+      and
+    $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+      and
+    $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
+  ) {
+    DBIx::Class::Exception->throw( sprintf (
+      "Illegal internal call of indirect proxy-method %s() with argument %s: examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n    Stacktrace starts",
+      $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {
+        require B::Deparse;
+        no strict 'refs';
+        B::Deparse->new->coderef2text(\&{$fr->[3]})
+      }),
+    ), 'with_stacktrace');
+  }
+}
+
 1;