From: Peter Rabbitson <ribasushi@cpan.org>
Date: Fri, 22 Jul 2016 10:59:40 +0000 (+0200)
Subject: An extra bit of diag on incomplete rsrc re-register
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d56e05c7;p=dbsrgits%2FDBIx-Class.git

An extra bit of diag on incomplete rsrc re-register

Due to the counterintuitive nature of the metadata subsystem, a user wishing
to modify the metadata for a result class at runtime (post $schema instance
initialization), may end up in a situation where *everything* appears to work
but falls apart on the next call to My::Schema->connect. In fact I myself made
this very mistake in https://github.com/ctrlo/GADS/pull/1/files, even though
I was pretty well aware of the dangers at the time.

In order to make this go away for good reuse the meta-metadata kept around to
track rsrc ancestry and modifications, and emit a warning alerting folks to
the potential problem (the *actual* problematic desync will also be warned
about at a later step by the stale-metadata diag).
---

diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index 9961c08..45dcd7e 100644
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -1466,7 +1466,7 @@ sub _register_source {
   $derived_rsrc->schema($self);
 
   weaken $derived_rsrc->{schema}
-    if length ref($self);
+    if length( my $schema_class = ref($self) );
 
   my %reg = %{$self->source_registrations};
   $reg{$source_name} = $derived_rsrc;
@@ -1498,6 +1498,44 @@ sub _register_source {
 
     $map{$result_class} = $source_name;
     $self->class_mappings(\%map);
+
+
+    my $schema_class_level_rsrc;
+    if (
+      # we are called on a schema instance, not on the class
+      length $schema_class
+
+        and
+
+      # the schema class also has a registration with the same name
+      $schema_class_level_rsrc = dbic_internal_try { $schema_class->source($source_name) }
+
+        and
+
+      # what we are registering on the schema instance *IS* derived
+      # from the class-level (top) rsrc...
+      ( grep { $_ == $derived_rsrc } $result_class_level_rsrc->__derived_instances )
+
+        and
+
+      # ... while the schema-class-level has stale-markers
+      keys %{ $schema_class_level_rsrc->{__metadata_divergencies} || {} }
+    ) {
+      my $msg =
+        "The ResultSource instance you just registered on '$self' as "
+      . "'$source_name' seems to have no relation to $schema_class->"
+      . "source('$source_name') which in turn is marked stale (likely due "
+      . "to recent $result_class->... direct class calls). This is almost "
+      . "always a mistake: perhaps you forgot a cycle of "
+      . "$schema_class->unregister_source( '$source_name' ) / "
+      . "$schema_class->register_class( '$source_name' => '$result_class' )"
+      ;
+
+      DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+        ? emit_loud_diag( msg => $msg, confess => 1 )
+        : carp_unique($msg)
+      ;
+    }
   }
 
   $derived_rsrc;
diff --git a/xt/extra/diagnostics/incomplete_reregister.t b/xt/extra/diagnostics/incomplete_reregister.t
new file mode 100644
index 0000000..27469b1
--- /dev/null
+++ b/xt/extra/diagnostics/incomplete_reregister.t
@@ -0,0 +1,26 @@
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
+# things will die if this is set
+BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 }
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+
+use DBICTest;
+
+my $s = DBICTest->init_schema( no_deploy => 1 );
+
+
+warnings_exist {
+  DBICTest::Schema::Artist->add_column("somethingnew");
+  $s->unregister_source("Artist");
+  $s->register_class( Artist => "DBICTest::Schema::Artist" );
+}
+  qr/The ResultSource instance you just registered on .+ \Qas 'Artist' seems to have no relation to DBICTest::Schema->source('Artist') which in turn is marked stale/,
+  'Expected warning on incomplete re-register of schema-class-level source'
+;
+
+done_testing;