X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=17a8bbafca3b41c1aa89c141133d77afa6c9e075;hb=c356fcb1919c92e9f9b1dfe9fcc4c4cd33dc5ad6;hp=9961c08d9a9142f8fa32b2050151346cf5304653;hpb=e570488ade8f327f47dd3318db3443a348d561d6;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index 9961c08..17a8bba 100644
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -7,8 +7,9 @@ use base 'DBIx::Class';
 
 use DBIx::Class::Carp;
 use Try::Tiny;
-use Scalar::Util qw/weaken blessed/;
+use Scalar::Util qw( weaken blessed refaddr );
 use DBIx::Class::_Util qw(
+  false emit_loud_diag refdesc
   refcount quote_sub scope_guard
   is_exception dbic_internal_try
   fail_on_internal_call emit_loud_diag
@@ -27,6 +28,12 @@ __PACKAGE__->mk_classaccessor('default_resultset_attributes' => {});
 __PACKAGE__->mk_classaccessor('class_mappings' => {});
 __PACKAGE__->mk_classaccessor('source_registrations' => {});
 
+__PACKAGE__->mk_group_accessors( component_class => 'schema_sanity_checker' );
+__PACKAGE__->schema_sanity_checker(
+  DBIx::Class::_ENV_::OLD_MRO ? false :
+  'DBIx::Class::Schema::SanityChecker'
+);
+
 =head1 NAME
 
 DBIx::Class::Schema - composable schemas
@@ -237,10 +244,6 @@ sub load_namespaces {
 
   my @to_register;
   {
-    no warnings qw/redefine/;
-    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
-    use warnings qw/redefine/;
-
     # ensure classes are loaded and attached in inheritance order
     for my $result_class (values %$results_by_source_name) {
       $class->ensure_class_loaded($result_class);
@@ -294,8 +297,6 @@ sub load_namespaces {
         .'with no corresponding Result class';
   }
 
-  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
-
   $class->register_class(@$_) for (@to_register);
 
   return;
@@ -377,10 +378,6 @@ sub load_classes {
 
   my @to_register;
   {
-    no warnings qw/redefine/;
-    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
-    use warnings qw/redefine/;
-
     foreach my $prefix (keys %comps_for) {
       foreach my $comp (@{$comps_for{$prefix}||[]}) {
         my $comp_class = "${prefix}::${comp}";
@@ -397,7 +394,6 @@ sub load_classes {
       }
     }
   }
-  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
 
   foreach my $to (@to_register) {
     $class->register_class(@$to);
@@ -454,6 +450,42 @@ Example:
    use base qw/DBIx::Class::Schema/;
    __PACKAGE__->default_resultset_attributes( { software_limit => 1 } );
 
+=head2 schema_sanity_checker
+
+=over 4
+
+=item Arguments: L<perform_schema_sanity_checks()|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> provider
+
+=item Return Value: L<perform_schema_sanity_checks()|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> provider
+
+=item Default value: L<DBIx::Class::Schema::SanityChecker>
+
+=back
+
+On every call to L</connection> if the value of this attribute evaluates to
+true, DBIC will invoke
+C<< L<$schema_sanity_checker|/schema_sanity_checker>->L<perform_schema_sanity_checks|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks>($schema) >>
+before returning. The return value of this invocation is ignored.
+
+B<YOU ARE STRONGLY URGED> to
+L<learn more about the reason|DBIx::Class::Schema::SanityChecker/WHY> this
+feature was introduced. Blindly disabling the checker on existing projects
+B<may result in data corruption> after upgrade to C<< DBIC >= v0.082900 >>.
+
+Example:
+
+   package My::Schema;
+   use base qw/DBIx::Class::Schema/;
+   __PACKAGE__->schema_sanity_checker('My::Schema::SanityChecker');
+
+   # or to disable all checks:
+   __PACKAGE__->schema_sanity_checker('');
+
+Note: setting the value to C<undef> B<will not> have the desired effect,
+due to an implementation detail of L<Class::Accessor::Grouped> inherited
+accessors. In order to disable any and all checks you must set this
+attribute to an empty string as shown in the second example above.
+
 =head2 exception_action
 
 =over 4
@@ -552,7 +584,7 @@ version, overload L</connection> instead.
 
 =cut
 
-sub connect {
+sub connect :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->clone->connection(@_);
 }
@@ -835,7 +867,7 @@ those values.
 
 =cut
 
-sub populate {
+sub populate :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
 
   my ($self, $name, $data) = @_;
@@ -859,12 +891,17 @@ Similar to L</connect> except sets the storage object and connection
 data B<in-place> on C<$self>. You should probably be calling
 L</connect> to get a properly L<cloned|/clone> Schema object instead.
 
+If the accessor L</schema_sanity_checker> returns a true value C<$checker>,
+the following call will take place before return:
+C<< L<$checker|/schema_sanity_checker>->L<perform_schema_sanity_checks(C<$self>)|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> >>
+
 =head3 Overloading
 
 Overload C<connection> to change the behaviour of C<connect>.
 
 =cut
 
+my $default_off_stderr_blurb_emitted;
 sub connection {
   my ($self, @info) = @_;
   return $self if !@info && $self->storage;
@@ -888,7 +925,53 @@ sub connection {
   my $storage = $storage_class->new( $self => $args||{} );
   $storage->connect_info(\@info);
   $self->storage($storage);
-  return $self;
+
+
+###
+### Begin 5.8 "you have not selected a checker" warning
+###
+  # We can not blanket-enable this on 5.8 - it is just too expensive for
+  # day to day execution. We also can't just go silent - there are genuine
+  # regressions ( due to core changes) for which this is the only line of
+  # defense. So instead we whine on STDERR that folks need to do something
+  #
+  # Beyond suboptimal, but given the constraints the best we can do :(
+  #
+  # This should stay around for at least 3~4 years
+  #
+  DBIx::Class::_ENV_::OLD_MRO
+    and
+  ! $default_off_stderr_blurb_emitted
+    and
+  length ref $self->schema_sanity_checker
+    and
+  length ref __PACKAGE__->schema_sanity_checker
+    and
+  (
+    refaddr( $self->schema_sanity_checker )
+      ==
+    refaddr( __PACKAGE__->schema_sanity_checker )
+  )
+    and
+  emit_loud_diag(
+    msg => sprintf(
+    "Sanity checks for schema %s are disabled on this perl $]: "
+  . '*THIS IS POTENTIALLY VERY DANGEROUS*. You are strongly urged to '
+  . "read http://is.gd/dbic_sancheck_5_008 before proceeding\n",
+    ( defined( blessed $self ) ? refdesc $self : "'$self'" )
+  ))
+    and
+  $default_off_stderr_blurb_emitted = 1;
+###
+### End 5.8 "you have not selected a checker" warning
+###
+
+
+  if( my $checker = $self->schema_sanity_checker ) {
+    $checker->perform_schema_sanity_checks($self);
+  }
+
+  $self;
 }
 
 sub _normalize_storage_type {
@@ -947,10 +1030,6 @@ sub compose_namespace {
   #$schema->class_mappings({});
 
   {
-    no warnings qw/redefine/;
-    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
-    use warnings qw/redefine/;
-
     foreach my $source_name ($self->sources) {
       my $orig_source = $self->source($source_name);
 
@@ -970,7 +1049,8 @@ sub compose_namespace {
       for qw(class source resultset);
   }
 
-  Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+  # needed to cover the newly installed stuff via quote_sub above
+  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
 
   # Give each composed class yet another *schema-less* source copy
   # this is used for the freeze/thaw cycle
@@ -1466,7 +1546,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 +1578,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;
@@ -1620,6 +1738,9 @@ sub compose_connection {
   my $schema = $self->compose_namespace($target, 'DBIx::Class::ResultSetProxy');
   quote_sub "${target}::schema", '$s', { '$s' => \$schema };
 
+  # needed to cover the newly installed stuff via quote_sub above
+  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
+
   $schema->connection(@info);
   foreach my $source_name ($schema->sources) {
     my $source = $schema->source($source_name);