From: Rob Kinyon <rkinyon@cpan.org>
Date: Sun, 15 Nov 2009 23:43:17 +0000 (+0000)
Subject: Moved the t/39* tests to XUnit as an example
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=79228cad187344b9a1a25b742974a14092bed04f;p=dbsrgits%2FDBIx-Class-Historic.git

Moved the t/39* tests to XUnit as an example
---

diff --git a/Makefile.PL b/Makefile.PL
index b41e281..268c40a 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -31,6 +31,8 @@ my $build_requires = {
 };
 
 my $test_requires = {
+  'Test::Class'              => '0.33',
+
   'File::Temp'               => '0.22',
   'Test::Exception'          => '0.31',
   'Test::Warn'               => '0.21',
diff --git a/t/39load_namespaces_1.t b/t/39load_namespaces_1.t
deleted file mode 100644
index d160040..0000000
--- a/t/39load_namespaces_1.t
+++ /dev/null
@@ -1,35 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
-my $warnings;
-eval {
-    local $SIG{__WARN__} = sub { $warnings .= shift };
-    package DBICNSTest;
-    use base qw/DBIx::Class::Schema/;
-    __PACKAGE__->load_namespaces;
-};
-ok(!$@, 'load_namespaces doesnt die') or diag $@;
-like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/, 'Found warning about extra ResultSet classes');
-
-like($warnings, qr/load_namespaces found ResultSet class DBICNSTest::ResultSet::D that does not subclass DBIx::Class::ResultSet/, 'Found warning about ResultSets with incorrect subclass');
-
-my $source_a = DBICNSTest->source('A');
-isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
-my $rset_a   = DBICNSTest->resultset('A');
-isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
-
-my $source_b = DBICNSTest->source('B');
-isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
-my $rset_b   = DBICNSTest->resultset('B');
-isa_ok($rset_b, 'DBIx::Class::ResultSet');
-
-for my $moniker (qw/A B/) {
-  my $class = "DBICNSTest::Result::$moniker";
-  ok(!defined($class->result_source_instance->source_name), "Source name of $moniker not defined");
-}
-
-done_testing;
diff --git a/t/39load_namespaces_2.t b/t/39load_namespaces_2.t
deleted file mode 100644
index 77cb9e0..0000000
--- a/t/39load_namespaces_2.t
+++ /dev/null
@@ -1,31 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
-plan tests => 6;
-
-my $warnings;
-eval {
-    local $SIG{__WARN__} = sub { $warnings .= shift };
-    package DBICNSTest;
-    use base qw/DBIx::Class::Schema/;
-    __PACKAGE__->load_namespaces(
-        result_namespace => 'Rslt',
-        resultset_namespace => 'RSet',
-    );
-};
-ok(!$@) or diag $@;
-like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
-
-my $source_a = DBICNSTest->source('A');
-isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
-my $rset_a   = DBICNSTest->resultset('A');
-isa_ok($rset_a, 'DBICNSTest::RSet::A');
-
-my $source_b = DBICNSTest->source('B');
-isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
-my $rset_b   = DBICNSTest->resultset('B');
-isa_ok($rset_b, 'DBIx::Class::ResultSet');
diff --git a/t/39load_namespaces_3.t b/t/39load_namespaces_3.t
deleted file mode 100644
index c1df868..0000000
--- a/t/39load_namespaces_3.t
+++ /dev/null
@@ -1,36 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-use Test::Exception;
-use Test::Warn;
-
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
-lives_ok (sub {
-  warnings_exist ( sub {
-      package DBICNSTestOther;
-      use base qw/DBIx::Class::Schema/;
-      __PACKAGE__->load_namespaces(
-          result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ],
-          resultset_namespace => '+DBICNSTest::RSet',
-      );
-    },
-    qr/load_namespaces found ResultSet class C with no corresponding Result class/,
-  );
-});
-
-my $source_a = DBICNSTestOther->source('A');
-isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
-my $rset_a   = DBICNSTestOther->resultset('A');
-isa_ok($rset_a, 'DBICNSTest::RSet::A');
-
-my $source_b = DBICNSTestOther->source('B');
-isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
-my $rset_b   = DBICNSTestOther->resultset('B');
-isa_ok($rset_b, 'DBIx::Class::ResultSet');
-
-my $source_d = DBICNSTestOther->source('D');
-isa_ok($source_d, 'DBIx::Class::ResultSource::Table');
-
-done_testing;
diff --git a/t/39load_namespaces_4.t b/t/39load_namespaces_4.t
deleted file mode 100644
index 7d9725e..0000000
--- a/t/39load_namespaces_4.t
+++ /dev/null
@@ -1,28 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
-plan tests => 6;
-
-my $warnings;
-eval {
-    local $SIG{__WARN__} = sub { $warnings .= shift };
-    package DBICNSTest;
-    use base qw/DBIx::Class::Schema/;
-    __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' );
-};
-ok(!$@) or diag $@;
-like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
-
-my $source_a = DBICNSTest->source('A');
-isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
-my $rset_a   = DBICNSTest->resultset('A');
-isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
-
-my $source_b = DBICNSTest->source('B');
-isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
-my $rset_b   = DBICNSTest->resultset('B');
-isa_ok($rset_b, 'DBICNSTest::RSBase');
diff --git a/t/39load_namespaces_exception.t b/t/39load_namespaces_exception.t
deleted file mode 100644
index c5a03df..0000000
--- a/t/39load_namespaces_exception.t
+++ /dev/null
@@ -1,19 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
-plan tests => 1;
-
-eval {
-    package DBICNSTest;
-    use base qw/DBIx::Class::Schema/;
-    __PACKAGE__->load_namespaces(
-        result_namespace => 'Bogus',
-        resultset_namespace => 'RSet',
-    );
-};
-
-like ($@, qr/are you sure this is a real Result Class/, 'Clear exception thrown');
diff --git a/t/39load_namespaces_rt41083.t b/t/39load_namespaces_rt41083.t
deleted file mode 100644
index 79c9c7a..0000000
--- a/t/39load_namespaces_rt41083.t
+++ /dev/null
@@ -1,65 +0,0 @@
-use strict;
-use warnings;
-
-use lib 't/lib';
-use DBICTest; # do not remove even though it is not used
-use Test::More tests => 8;
-
-sub _chk_warning {
-  defined $_[0]?
-    $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ :
-    1
-}
-
-sub _chk_extra_sources_warning {
-  my $p = qr/already has a source, use register_extra_source for additional sources/;
-  defined $_[0]? $_[0] !~ /$p/ : 1;
-}
-
-sub _verify_sources {
-  my @monikers = @_;
-  is_deeply (
-    [ sort DBICNSTest::RtBug41083->sources ],
-    \@monikers,
-    'List of resultsource registrations',
-  );
-}
-
-{
-  my $warnings;
-  eval {
-    local $SIG{__WARN__} = sub { $warnings .= shift };
-    package DBICNSTest::RtBug41083;
-    use base 'DBIx::Class::Schema';
-    __PACKAGE__->load_namespaces(
-      result_namespace => 'Schema_A',
-      resultset_namespace => 'ResultSet_A',
-      default_resultset_class => 'ResultSet'
-    );
-  };
-
-  ok(!$@) or diag $@;
-  ok(_chk_warning($warnings), 'expected no resultset complaint');
-  ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
-
-  _verify_sources (qw/A A::Sub/);
-}
-
-{
-  my $warnings;
-  eval {
-    local $SIG{__WARN__} = sub { $warnings .= shift };
-    package DBICNSTest::RtBug41083;
-    use base 'DBIx::Class::Schema';
-    __PACKAGE__->load_namespaces(
-      result_namespace => 'Schema',
-      resultset_namespace => 'ResultSet',
-      default_resultset_class => 'ResultSet'
-    );
-  };
-  ok(!$@) or diag $@;
-  ok(_chk_warning($warnings), 'expected no resultset complaint') or diag $warnings;
-  ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
-
-  _verify_sources (qw/A A::Sub Foo Foo::Sub/);
-}
diff --git a/t/lib/XUnit.pm b/t/lib/XUnit.pm
new file mode 100644
index 0000000..9db6d44
--- /dev/null
+++ b/t/lib/XUnit.pm
@@ -0,0 +1,35 @@
+package # Hide from PAUSE
+    XUnit;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( Test::Class );
+
+INIT { Test::Class->runtests }
+
+BEGIN {
+    # XXX Need a better way to do this.
+    my $subs_for = sub {
+        my $pkg = shift;
+        no strict 'refs';
+        return grep { defined &{"${pkg}::${_}"} } keys %{"${pkg}::"};
+    };
+
+    my @packages = qw(
+        Test::More
+    );
+
+    foreach my $pkg ( @packages ) {
+        eval "use $pkg ();";
+        die $@ if $@;
+        foreach my $subroutine ( $subs_for->($pkg) ) {
+            next if __PACKAGE__->can($subroutine);
+            eval qq| sub $subroutine { shift; goto &{"${pkg}::${subroutine}"} } |;
+            die $@ if $@;
+        }
+    }
+}
+
+1;
+__END__
diff --git a/t/lib/XUnit/LoadNamespace.pm b/t/lib/XUnit/LoadNamespace.pm
new file mode 100644
index 0000000..e282fe3
--- /dev/null
+++ b/t/lib/XUnit/LoadNamespace.pm
@@ -0,0 +1,206 @@
+package
+    XUnit::LoadNameSpace;
+
+use strict;
+use warnings FATAL => 'all';
+
+use base qw( XUnit );
+
+sub test1 : Tests(8) {
+    my $self = shift;
+
+    my $warnings;
+    eval {
+        local $SIG{__WARN__} = sub { $warnings .= shift };
+        package DBICNSTest;
+        use base qw/DBIx::Class::Schema/;
+        __PACKAGE__->load_namespaces;
+    };
+    $self->ok(!$@) or diag $@;
+    $self->like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+
+    my $source_a = DBICNSTest->source('A');
+    $self->isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
+    my $rset_a   = DBICNSTest->resultset('A');
+    $self->isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
+
+    my $source_b = DBICNSTest->source('B');
+    $self->isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
+    my $rset_b   = DBICNSTest->resultset('B');
+    $self->isa_ok($rset_b, 'DBIx::Class::ResultSet');
+
+    for my $moniker (qw/A B/) {
+        my $class = "DBICNSTest::Result::$moniker";
+        $self->ok(!defined($class->result_source_instance->source_name));
+    }
+}
+
+sub test2 : Tests(6) {
+    my $self = shift;
+
+    my $warnings;
+    eval {
+        local $SIG{__WARN__} = sub { $warnings .= shift };
+        package DBICNSTest;
+        use base qw/DBIx::Class::Schema/;
+        __PACKAGE__->load_namespaces(
+            result_namespace => 'Rslt',
+            resultset_namespace => 'RSet',
+        );
+    };
+    $self->ok(!$@) or diag $@;
+    $self->like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+
+    my $source_a = DBICNSTest->source('A');
+    $self->isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
+    my $rset_a   = DBICNSTest->resultset('A');
+    $self->isa_ok($rset_a, 'DBICNSTest::RSet::A');
+
+    my $source_b = DBICNSTest->source('B');
+    $self->isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
+    my $rset_b   = DBICNSTest->resultset('B');
+    $self->isa_ok($rset_b, 'DBIx::Class::ResultSet');
+}
+
+sub test3 : Tests(7) {
+    my $self = shift;
+
+    my $warnings;
+    eval {
+        local $SIG{__WARN__} = sub { $warnings .= shift };
+        package DBICNSTestOther;
+        use base qw/DBIx::Class::Schema/;
+        __PACKAGE__->load_namespaces(
+            result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ],
+            resultset_namespace => '+DBICNSTest::RSet',
+        );
+    };
+    $self->ok(!$@) or diag $@;
+    $self->like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+
+    my $source_a = DBICNSTestOther->source('A');
+    $self->isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
+    my $rset_a   = DBICNSTestOther->resultset('A');
+    $self->isa_ok($rset_a, 'DBICNSTest::RSet::A');
+
+    my $source_b = DBICNSTestOther->source('B');
+    $self->isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
+    my $rset_b   = DBICNSTestOther->resultset('B');
+    $self->isa_ok($rset_b, 'DBIx::Class::ResultSet');
+
+    my $source_d = DBICNSTestOther->source('D');
+    $self->isa_ok($source_d, 'DBIx::Class::ResultSource::Table');
+}
+
+sub test4 : Tests(6) {
+    my $self = shift;
+
+    my $warnings;
+    eval {
+        local $SIG{__WARN__} = sub { $warnings .= shift };
+        package DBICNSTest;
+        use base qw/DBIx::Class::Schema/;
+        __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' );
+    };
+    $self->ok(!$@) or diag $@;
+    $self->like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+
+    my $source_a = DBICNSTest->source('A');
+    $self->isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
+    my $rset_a   = DBICNSTest->resultset('A');
+    $self->isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
+
+    my $source_b = DBICNSTest->source('B');
+    $self->isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
+    my $rset_b   = DBICNSTest->resultset('B');
+    $self->isa_ok($rset_b, 'DBICNSTest::RSBase');
+}
+
+sub exception : Tests(1) {
+    my $self = shift;
+
+    eval {
+        package DBICNSTest;
+        use base qw/DBIx::Class::Schema/;
+        __PACKAGE__->load_namespaces(
+            result_namespace => 'Bogus',
+            resultset_namespace => 'RSet',
+        );
+    };
+
+    $self->like ($@, qr/are you sure this is a real Result Class/, 'Clear exception thrown');
+}
+
+sub rt41083_case1 : Tests(4) {
+    my $self = shift;
+
+    my $warnings;
+    eval {
+        local $SIG{__WARN__} = sub { $warnings .= shift };
+        package DBICNSTest::RtBug41083;
+        use base 'DBIx::Class::Schema';
+        __PACKAGE__->load_namespaces(
+            result_namespace => 'Schema_A',
+            resultset_namespace => 'ResultSet_A',
+            default_resultset_class => 'ResultSet'
+        );
+    };
+
+    $self->ok(!$@) or diag $@;
+    $self->check_warnings($warnings);
+    $self->verify_sources(qw/A A::Sub/);
+}
+
+sub rt41083_case2 : Tests(4) {
+    my $self = shift;
+
+    my $warnings;
+    eval {
+        local $SIG{__WARN__} = sub { $warnings .= shift };
+        package DBICNSTest::RtBug41083;
+        use base 'DBIx::Class::Schema';
+        __PACKAGE__->load_namespaces(
+            result_namespace => 'Schema',
+            resultset_namespace => 'ResultSet',
+            default_resultset_class => 'ResultSet'
+        );
+    };
+    $self->ok(!$@) or diag $@;
+    $self->check_warnings($warnings);
+    $self->verify_sources(qw/A A::Sub Foo Foo::Sub/);
+}
+
+sub check_warnings {
+    my $self = shift;
+    my ($warnings) = @_;
+
+    if ( defined $warnings ) {
+        $self->unlike(
+            qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/,
+            "Have a warning, but it's ok"
+        )
+        and
+        $self->unlike(
+            qr/already has a source, use register_extra_source for additional sources/,
+            "Have a warning, but it's ok"
+        )
+        or $self->diag( $warnings );
+    }
+    else {
+        $self->ok( 1, "No complaints" );
+        $self->ok( 1, "No complaints" );
+    }
+}
+
+sub verify_sources {
+    my $self = shift;
+    my @monikers = @_;
+    $self->is_deeply (
+        [ sort DBICNSTest::RtBug41083->sources ],
+        \@monikers,
+        'List of resultsource registrations',
+    );
+}
+
+1;
+__END__
diff --git a/t/xunit.t b/t/xunit.t
new file mode 100644
index 0000000..8858f33
--- /dev/null
+++ b/t/xunit.t
@@ -0,0 +1,8 @@
+#!/usr/bin/perl -T
+
+use strict;
+use warnings;
+
+use lib qw( t/lib );
+
+use Test::Class::Load 't/lib/XUnit';