From: Maik Hentsche <maik.hentsche@amd.com>
Date: Mon, 14 Jun 2010 10:47:35 +0000 (+0200)
Subject: Unit test for deriving from result classes
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6a9436dc6215461a90e4f68d2a474e1fb5f0558f;p=dbsrgits%2FDBIx-Class.git

Unit test for deriving from result classes

Note: This test does not work yet. It shows who deriving classes from
DBIC result classes should work. This test is the result of a
discussion of this topic at the German Perl Workshop.
---

diff --git a/t/105_compose_namespace.t b/t/105_compose_namespace.t
new file mode 100644
index 0000000..bf16f8f
--- /dev/null
+++ b/t/105_compose_namespace.t
@@ -0,0 +1,46 @@
+use lib qw(t/lib);
+use DBICTest;
+use Test::More;
+
+my $db_file = "t/var/NSplain.db";
+
+unlink($db_file) if -e $db_file;
+unlink($db_file . "-journal") if -e $db_file . "-journal";
+mkdir("t/var") unless -d "t/var";
+
+my $dsn = "dbi:SQLite:${db_file}";
+
+eval {
+    local $SIG{__WARN__} = sub {};
+    package DBICNSTest;
+    use base qw/DBIx::Class::Schema/;
+    __PACKAGE__->load_namespaces;
+};
+ok(!$@, 'load_namespaces does not die') or diag $@;
+
+eval {
+    package Derived::Schema::Result::A;
+    use base qw/DBICNSTest::Result::A/;
+    sub whoami { 'derived result' }
+};
+ok(!$@, 'Deriving result does not die') or diag $@;
+
+
+my $model         = DBICNSTest->connect($dsn);
+$model->storage->dbh_do(sub { $_[1]->do('CREATE TABLE a (a INT)')});
+$model->populate('A', [ [ 'a' ], [  17 ] ]);
+
+my $derived_model = DBICNSTest->compose_namespace('Derived::Schema')->connect($dsn);
+
+my $rset   = DBICNSTest->resultset('A');
+isa_ok($rset, 'DBICNSTest::ResultSet::A');
+
+my $rset   = $derived_model->resultset('A');
+isa_ok($rset, 'Derived::Schema::ResultSet::A','Derived resultset');
+
+my $result = $rset->search({})->first;
+is($result->a(), 17, 'Value of base result seen in derived result');
+isa_ok($result, 'Derived::Schema::Result::A', 'Derived schema result');
+can_ok($result, 'whoami');
+
+done_testing();