implement schema_base_class for dynamic schemas

Implement schema_base_class and schema_components support for dynamic
schemas at 'connection' time.

Augment btilly's test to check that schema_components are also applied
at 'connection' time.

This requires a rather horrible hack in ::Loader::connection, because
mro cannot normally deal with a changing @ISA inside of a call chain,
but it works.

diff --git a/Makefile.PL b/Makefile.PL
index e11bfb7..61e956b 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -44,6 +44,7 @@ requires 'Lingua::EN::Inflect::Phrase' => '0.02';
 requires 'Digest::MD5'                 => '2.36';
 requires 'Class::Accessor::Grouped'    => '0.10002';
 requires 'MRO::Compat'                 => '0.09';
+requires 'Sub::Name'                   => 0;
 requires 'Class::C3::Componentised'    => '1.0008';
 requires 'Carp::Clan'                  => 0;
 requires 'Class::Inspector'            => 0;

diff --git a/lib/DBIx/Class/Schema/Loader.pm b/lib/DBIx/Class/Schema/Loader.pm
index 7f33215..78b0507 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader.pm
+++ b/lib/DBIx/Class/Schema/Loader.pm
@@ -3,9 +3,11 @@ package DBIx::Class::Schema::Loader;
 use strict;
 use warnings;
 use base qw/DBIx::Class::Schema Class::Accessor::Grouped/;
+use MRO::Compat;
 use mro 'c3';
 use Carp::Clan qw/^DBIx::Class/;
 use Scalar::Util 'weaken';
+use Sub::Name 'subname';
 use namespace::clean;
 
 # Always remember to do all digits for the version even if they're 0
@@ -219,7 +221,7 @@ sub connection {
     my $self = shift;
 
     if($_[-1] && ref $_[-1] eq 'HASH') {
-        for my $option (qw/ loader_class loader_options result_base_class schema_base_class/) {
+        for my $option (qw/loader_class loader_options/) {
             if(my $value = delete $_[-1]->{$option}) {
                 $self->$option($value);
             }
@@ -227,7 +229,34 @@ sub connection {
         pop @_ if !keys %{$_[-1]};
     }
 
-    $self = $self->next::method(@_);
+    # Make sure we inherit from schema_base_class and load schema_components
+    # before connecting.
+    require DBIx::Class::Schema::Loader::Base;
+    my $temp_loader = DBIx::Class::Schema::Loader::Base->new(
+        %{ $self->_loader_args }
+    );
+
+    if ($temp_loader->schema_base_class || $temp_loader->schema_components) {
+        my @components = @{ $temp_loader->schema_components }
+            if $temp_loader->schema_components;
+
+        push @components, ('+'.$temp_loader->schema_base_class)
+            if $temp_loader->schema_base_class;
+
+        $self->load_components(@components);
+    }
+
+    # This hack is necessary if we changed @ISA of $self through ->load_components.
+    {
+        no warnings 'redefine';
+
+        local *connection = subname __PACKAGE__.'::connection' => sub {
+            my $self = shift;
+            $self->next::method(@_);
+        };
+
+        $self = $self->connection(@_);
+    }
 
     my $class = ref $self || $self;
     if(!$class->_loader_invoked) {

diff --git a/t/60schema_base_dispatched.t b/t/60schema_base_dispatched.t
deleted file mode 100644 (file)
index abba311..0000000
--- a/t/60schema_base_dispatched.t
+++ /dev/null
@@ -1,21 +0,0 @@
-# test that the class in schema_base_class gets used when loading the schema
-# by Ben Tilly (  btilly -at|   gmail.com )
-
-use strict;
-use Test::More tests => 1;
-use DBIx::Class::Schema::Loader qw(make_schema_at);
-use lib 't/lib';
-use make_dbictest_db;
-
-make_schema_at(
-    'DBICTest::Schema::_test_schema_base',
-    {
-        really_erase_my_files => 1,
-       naming => 'current',
-       use_namespaces => 0,
-       schema_base_class => 'TestSchemaBaseClass',
-    },
-    [ $make_dbictest_db::dsn ],
-);
-
-ok($TestSchemaBaseClass::test_ok, "Connected using schema_base_class.");

diff --git a/t/70schema_base_dispatched.t b/t/70schema_base_dispatched.t
new file mode 100644 (file)
index 0000000..b0dae81
--- /dev/null
+++ b/t/70schema_base_dispatched.t
@@ -0,0 +1,23 @@
+use strict;
+use warnings;
+no warnings 'once';
+use Test::More tests => 2;
+use DBIx::Class::Schema::Loader 'make_schema_at';
+use lib 't/lib';
+use make_dbictest_db;
+
+make_schema_at(
+    'DBICTest::Schema::_test_schema_base',
+    {
+       naming => 'current',
+       schema_base_class => 'TestSchemaBaseClass',
+        schema_components => ['TestSchemaComponent'],
+    },
+    [ $make_dbictest_db::dsn ],
+);
+
+ok $TestSchemaBaseClass::test_ok,
+    'connected using schema_base_class';
+
+ok $DBIx::Class::TestSchemaComponent::test_component_ok,
+    'connected using schema_components';

diff --git a/t/lib/DBIx/Class/TestSchemaComponent.pm b/t/lib/DBIx/Class/TestSchemaComponent.pm
index 21cd853..6e83dc6 100644 (file)
--- a/t/lib/DBIx/Class/TestSchemaComponent.pm
+++ b/t/lib/DBIx/Class/TestSchemaComponent.pm
@@ -1,5 +1,18 @@
 package DBIx::Class::TestSchemaComponent;
 
+use strict;
+use warnings;
+
+our $test_component_ok = 0;
+
+sub connection {
+    my ($self, @info) = @_;
+
+    $test_component_ok = 1;
+
+    return $self->next::method(@info);
+}
+
 sub dbix_class_testschemacomponent { 'dbix_class_testschemacomponent works' }
 
 1;