From: Rafael Kitover <rkitover@cpan.org>
Date: Wed, 9 Nov 2011 02:33:46 +0000 (-0500)
Subject: fix code running 2x in dynamic schema_base_class
X-Git-Tag: 0.07012~4
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Schema-Loader.git;a=commitdiff_plain;h=50b95db6f08695f02fd804bc71c6c222cd310d05

fix code running 2x in dynamic schema_base_class

Fix a bug that ran the connection method in
schema_base_class/schema_components twice on the second connect, with
tests.

Move the RelBuilder _array_eq method to an array_eq sub in Utils.
---

diff --git a/Changes b/Changes
index 4fb5c90..565df14 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - fix a bug in dynamic schema_base_class/schema_components
+          implementation that ran the connection method twice on subsequent
+          connects
         - use a temp file for filter_generated_code with a string program name
           instead of IPC::Open2, which hangs on Win32 (RT#72226)
         - previous version referred to the wrong RT# for the uniq_to_primary
diff --git a/lib/DBIx/Class/Schema/Loader.pm b/lib/DBIx/Class/Schema/Loader.pm
index 80a3196..9c7fd02 100644
--- a/lib/DBIx/Class/Schema/Loader.pm
+++ b/lib/DBIx/Class/Schema/Loader.pm
@@ -8,6 +8,7 @@ use mro 'c3';
 use Carp::Clan qw/^DBIx::Class/;
 use Scalar::Util 'weaken';
 use Sub::Name 'subname';
+use DBIx::Class::Schema::Loader::Utils 'array_eq';
 use namespace::clean;
 
 # Always remember to do all digits for the version even if they're 0
@@ -240,13 +241,29 @@ sub connection {
         use_namespaces => 1,
     );
 
+    my $modify_isa = 0;
+    my @components;
+
     if ($temp_loader->schema_base_class || $temp_loader->schema_components) {
-        my @components = @{ $temp_loader->schema_components }
+        @components = @{ $temp_loader->schema_components }
             if $temp_loader->schema_components;
 
         push @components, ('+'.$temp_loader->schema_base_class)
             if $temp_loader->schema_base_class;
 
+        my $class_isa = do {
+            no strict 'refs';
+            \@{"${class}::ISA"};
+        };
+
+        my @component_classes = map {
+            /^\+/ ? substr($_, 1, length($_) - 1) : "DBIx::Class::$_"
+        } @components;
+
+        $modify_isa++ if not array_eq([ @$class_isa[0..(@components-1)] ], \@component_classes)
+    }
+
+    if ($modify_isa) {
         $class->load_components(@components);
 
         # This hack is necessary because we changed @ISA of $self through
diff --git a/lib/DBIx/Class/Schema/Loader/RelBuilder.pm b/lib/DBIx/Class/Schema/Loader/RelBuilder.pm
index 14f618d..43810ac 100644
--- a/lib/DBIx/Class/Schema/Loader/RelBuilder.pm
+++ b/lib/DBIx/Class/Schema/Loader/RelBuilder.pm
@@ -6,7 +6,7 @@ use base 'Class::Accessor::Grouped';
 use mro 'c3';
 use Carp::Clan qw/^DBIx::Class/;
 use Scalar::Util 'weaken';
-use DBIx::Class::Schema::Loader::Utils qw/split_name slurp_file/;
+use DBIx::Class::Schema::Loader::Utils qw/split_name slurp_file array_eq/;
 use Try::Tiny;
 use List::MoreUtils qw/apply uniq any/;
 use namespace::clean;
@@ -276,17 +276,6 @@ sub _strip_id_postfix {
     return $name;
 }
 
-sub _array_eq {
-    my ($self, $a, $b) = @_;
-
-    return unless @$a == @$b;
-
-    for (my $i = 0; $i < @$a; $i++) {
-        return unless $a->[$i] eq $b->[$i];
-    }
-    return 1;
-}
-
 sub _remote_attrs {
     my ($self, $local_moniker, $local_cols) = @_;
 
@@ -685,8 +674,8 @@ sub _relnames_and_method {
     my $remote_method = 'has_many';
 
     # If the local columns have a UNIQUE constraint, this is a one-to-one rel
-    if ($self->_array_eq([ $local_source->primary_columns ], $local_cols) ||
-            grep { $self->_array_eq($_->[1], $local_cols) } @$uniqs) {
+    if (array_eq([ $local_source->primary_columns ], $local_cols) ||
+            grep { array_eq($_->[1], $local_cols) } @$uniqs) {
         $remote_method   = 'might_have';
         ($local_relname) = $self->_inflect_singular($local_relname_uninflected);
     }
@@ -716,7 +705,7 @@ sub _relnames_and_method {
                 my $rel_cols = [ sort { $a cmp $b } apply { s/^foreign\.//i }
                     (keys %{ $class->relationship_info($local_relname)->{cond} }) ];
 
-                $relationship_exists = 1 if $self->_array_eq([ sort @$local_cols ], $rel_cols);
+                $relationship_exists = 1 if array_eq([ sort @$local_cols ], $rel_cols);
             }
         }
 
diff --git a/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_05.pm b/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_05.pm
index 7e70024..01691fd 100644
--- a/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_05.pm
+++ b/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_05.pm
@@ -4,6 +4,8 @@ use strict;
 use warnings;
 use base 'DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06';
 use mro 'c3';
+use DBIx::Class::Schema::Loader::Utils 'array_eq';
+use namespace::clean;
 use Lingua::EN::Inflect::Number ();
 
 our $VERSION = '0.07011';
@@ -53,8 +55,8 @@ sub _relnames_and_method {
 
     # If the local columns have a UNIQUE constraint, this is a one-to-one rel
     my $local_source = $self->{schema}->source($local_moniker);
-    if ($self->_array_eq([ $local_source->primary_columns ], $local_cols) ||
-            grep { $self->_array_eq($_->[1], $local_cols) } @$uniqs) {
+    if (array_eq([ $local_source->primary_columns ], $local_cols) ||
+            grep { array_eq($_->[1], $local_cols) } @$uniqs) {
         $remote_method = 'might_have';
         ($local_relname) = $self->_inflect_singular($local_relname_uninflected);
     }
diff --git a/lib/DBIx/Class/Schema/Loader/Utils.pm b/lib/DBIx/Class/Schema/Loader/Utils.pm
index 77a8259..544d2ff 100644
--- a/lib/DBIx/Class/Schema/Loader/Utils.pm
+++ b/lib/DBIx/Class/Schema/Loader/Utils.pm
@@ -6,11 +6,12 @@ use warnings;
 use Test::More;
 use String::CamelCase 'wordsplit';
 use Carp::Clan qw/^DBIx::Class/;
+use Scalar::Util 'looks_like_number';
 use namespace::clean;
 use Exporter 'import';
 use Data::Dumper ();
 
-our @EXPORT_OK = qw/split_name dumper dumper_squashed eval_package_without_redefine_warnings class_path no_warnings warnings_exist warnings_exist_silent slurp_file write_file/;
+our @EXPORT_OK = qw/split_name dumper dumper_squashed eval_package_without_redefine_warnings class_path no_warnings warnings_exist warnings_exist_silent slurp_file write_file array_eq/;
 
 use constant BY_CASE_TRANSITION_V7 =>
     qr/(?<=[[:lower:]\d])[\W_]*(?=[[:upper:]])|[\W_]+/;
@@ -168,5 +169,22 @@ sub write_file($$) {
     close $fh;
 }
 
+sub array_eq($$) {
+    no warnings 'uninitialized';
+    my ($a, $b) = @_;
+
+    return unless @$a == @$b;
+
+    for (my $i = 0; $i < @$a; $i++) {
+        if (looks_like_number $a->[$i]) {
+            return unless $a->[$i] == $b->[$i];
+        }
+        else {
+            return unless $a->[$i] eq $b->[$i];
+        }
+    }
+    return 1;
+}
+
 1;
 # vim:et sts=4 sw=4 tw=0:
diff --git a/t/70schema_base_dispatched.t b/t/70schema_base_dispatched.t
index 3d70db5..8e0756f 100644
--- a/t/70schema_base_dispatched.t
+++ b/t/70schema_base_dispatched.t
@@ -1,6 +1,6 @@
 use strict;
 use warnings;
-use Test::More tests => 8;
+use Test::More tests => 10;
 use DBIx::Class::Schema::Loader 'make_schema_at';
 use lib 't/lib';
 use make_dbictest_db;
@@ -15,50 +15,58 @@ make_schema_at(
     [ $make_dbictest_db::dsn ],
 );
 
-ok $TestSchemaBaseClass::test_ok,
+is $TestSchemaBaseClass::test_ok, 1,
     'connected using schema_base_class';
 
-ok $DBIx::Class::TestSchemaComponent::test_component_ok,
+is $DBIx::Class::TestSchemaComponent::test_component_ok, 1,
     'connected using schema_components';
 
 # try an explicit dynamic schema
 
-$TestSchemaBaseClass::test_ok = 0;
-$DBIx::Class::TestSchemaComponent::test_component_ok = 0;
-
 {
     package DBICTest::Schema::_test_schema_base_dynamic;
     use base 'DBIx::Class::Schema::Loader';
+    our $ran_connection = 0;
     __PACKAGE__->loader_options({
         naming => 'current',
         schema_base_class => 'TestSchemaBaseClass',
         schema_components => ['TestSchemaComponent'],
     });
     # check that connection doesn't cause an infinite loop
-    sub connection { my $self = shift; return $self->next::method(@_) }
+    sub connection { my $self = shift; $ran_connection++; return $self->next::method(@_) }
 }
 
+$TestSchemaBaseClass::test_ok = 0;
+$DBIx::Class::TestSchemaComponent::test_component_ok = 0;
+
 ok(my $schema =
     DBICTest::Schema::_test_schema_base_dynamic->connect($make_dbictest_db::dsn),
     'connected dynamic schema');
 
-ok $TestSchemaBaseClass::test_ok,
+is $DBICTest::Schema::_test_schema_base_dynamic::ran_connection, 1,
+    'schema class connection method ran only once';
+
+is $TestSchemaBaseClass::test_ok, 1,
     'connected using schema_base_class in dynamic schema';
 
-ok $DBIx::Class::TestSchemaComponent::test_component_ok,
+is $DBIx::Class::TestSchemaComponent::test_component_ok, 1,
     'connected using schema_components in dynamic schema';
 
 # connect a second time
 
 $TestSchemaBaseClass::test_ok = 0;
 $DBIx::Class::TestSchemaComponent::test_component_ok = 0;
+$DBICTest::Schema::_test_schema_base_dynamic::ran_connection = 0;
 
 ok($schema =
     DBICTest::Schema::_test_schema_base_dynamic->connect($make_dbictest_db::dsn),
     'connected dynamic schema a second time');
 
-ok $TestSchemaBaseClass::test_ok,
+is $DBICTest::Schema::_test_schema_base_dynamic::ran_connection, 1,
+'schema class connection method ran only once when connecting a second time';
+
+is $TestSchemaBaseClass::test_ok, 1,
     'connected using schema_base_class in dynamic schema a second time';
 
-ok $DBIx::Class::TestSchemaComponent::test_component_ok,
+is $DBIx::Class::TestSchemaComponent::test_component_ok, 1,
     'connected using schema_components in dynamic schema a second time';
diff --git a/t/lib/DBIx/Class/TestSchemaComponent.pm b/t/lib/DBIx/Class/TestSchemaComponent.pm
index 6e83dc6..e277880 100644
--- a/t/lib/DBIx/Class/TestSchemaComponent.pm
+++ b/t/lib/DBIx/Class/TestSchemaComponent.pm
@@ -8,7 +8,7 @@ our $test_component_ok = 0;
 sub connection {
     my ($self, @info) = @_;
 
-    $test_component_ok = 1;
+    $test_component_ok++;
 
     return $self->next::method(@info);
 }
diff --git a/t/lib/TestSchemaBaseClass.pm b/t/lib/TestSchemaBaseClass.pm
index dc4e955..b83172b 100644
--- a/t/lib/TestSchemaBaseClass.pm
+++ b/t/lib/TestSchemaBaseClass.pm
@@ -7,7 +7,7 @@ sub connection {
     my ($self, @info) = @_;
 
     if ($info[0] =~ /^dbi/) {
-        $test_ok = 1;
+        $test_ok++;
     }
 
     return $self->next::method(@info);