[Bast-commits] r7913 - in DBIx-Class/0.08/branches/test_class: . t t/lib t/lib/XUnit

robkinyon at dev.catalyst.perl.org robkinyon at dev.catalyst.perl.org
Sun Nov 15 23:43:18 GMT 2009


Author: robkinyon
Date: 2009-11-15 23:43:17 +0000 (Sun, 15 Nov 2009)
New Revision: 7913

Added:
   DBIx-Class/0.08/branches/test_class/t/lib/XUnit.pm
   DBIx-Class/0.08/branches/test_class/t/lib/XUnit/
   DBIx-Class/0.08/branches/test_class/t/lib/XUnit/LoadNamespace.pm
   DBIx-Class/0.08/branches/test_class/t/xunit.t
Removed:
   DBIx-Class/0.08/branches/test_class/t/39load_namespaces_1.t
   DBIx-Class/0.08/branches/test_class/t/39load_namespaces_2.t
   DBIx-Class/0.08/branches/test_class/t/39load_namespaces_3.t
   DBIx-Class/0.08/branches/test_class/t/39load_namespaces_4.t
   DBIx-Class/0.08/branches/test_class/t/39load_namespaces_exception.t
   DBIx-Class/0.08/branches/test_class/t/39load_namespaces_rt41083.t
Modified:
   DBIx-Class/0.08/branches/test_class/Makefile.PL
Log:
Moved the t/39* tests to XUnit as an example

Modified: DBIx-Class/0.08/branches/test_class/Makefile.PL
===================================================================
--- DBIx-Class/0.08/branches/test_class/Makefile.PL	2009-11-15 23:00:46 UTC (rev 7912)
+++ DBIx-Class/0.08/branches/test_class/Makefile.PL	2009-11-15 23:43:17 UTC (rev 7913)
@@ -13,6 +13,7 @@
 
 
 test_requires 'Test::Builder'       => '0.33';
+test_requires 'Test::Class'         => '0.33';
 test_requires 'Test::Deep'          => '0';
 test_requires 'Test::Exception'     => '0';
 test_requires 'Test::More'          => '0.92';

Deleted: DBIx-Class/0.08/branches/test_class/t/39load_namespaces_1.t
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/39load_namespaces_1.t	2009-11-15 23:00:46 UTC (rev 7912)
+++ DBIx-Class/0.08/branches/test_class/t/39load_namespaces_1.t	2009-11-15 23:43:17 UTC (rev 7913)
@@ -1,35 +0,0 @@
-#!/usr/bin/perl
-
-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 => 8;
-
-my $warnings;
-eval {
-    local $SIG{__WARN__} = sub { $warnings .= shift };
-    package DBICNSTest;
-    use base qw/DBIx::Class::Schema/;
-    __PACKAGE__->load_namespaces;
-};
-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, 'DBIx::Class::ResultSet');
-
-for my $moniker (qw/A B/) {
-  my $class = "DBICNSTest::Result::$moniker";
-  ok(!defined($class->result_source_instance->source_name));
-}

Deleted: DBIx-Class/0.08/branches/test_class/t/39load_namespaces_2.t
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/39load_namespaces_2.t	2009-11-15 23:00:46 UTC (rev 7912)
+++ DBIx-Class/0.08/branches/test_class/t/39load_namespaces_2.t	2009-11-15 23:43:17 UTC (rev 7913)
@@ -1,33 +0,0 @@
-#!/usr/bin/perl
-
-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');

Deleted: DBIx-Class/0.08/branches/test_class/t/39load_namespaces_3.t
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/39load_namespaces_3.t	2009-11-15 23:00:46 UTC (rev 7912)
+++ DBIx-Class/0.08/branches/test_class/t/39load_namespaces_3.t	2009-11-15 23:43:17 UTC (rev 7913)
@@ -1,36 +0,0 @@
-#!/usr/bin/perl
-
-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 => 7;
-
-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',
-    );
-};
-ok(!$@) or diag $@;
-like($warnings, 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');

Deleted: DBIx-Class/0.08/branches/test_class/t/39load_namespaces_4.t
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/39load_namespaces_4.t	2009-11-15 23:00:46 UTC (rev 7912)
+++ DBIx-Class/0.08/branches/test_class/t/39load_namespaces_4.t	2009-11-15 23:43:17 UTC (rev 7913)
@@ -1,30 +0,0 @@
-#!/usr/bin/perl
-
-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');

Deleted: DBIx-Class/0.08/branches/test_class/t/39load_namespaces_exception.t
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/39load_namespaces_exception.t	2009-11-15 23:00:46 UTC (rev 7912)
+++ DBIx-Class/0.08/branches/test_class/t/39load_namespaces_exception.t	2009-11-15 23:43:17 UTC (rev 7913)
@@ -1,21 +0,0 @@
-#!/usr/bin/perl
-
-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');

Deleted: DBIx-Class/0.08/branches/test_class/t/39load_namespaces_rt41083.t
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/39load_namespaces_rt41083.t	2009-11-15 23:00:46 UTC (rev 7912)
+++ DBIx-Class/0.08/branches/test_class/t/39load_namespaces_rt41083.t	2009-11-15 23:43:17 UTC (rev 7913)
@@ -1,67 +0,0 @@
-#!/usr/bin/perl
-
-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/);
-}

Added: DBIx-Class/0.08/branches/test_class/t/lib/XUnit/LoadNamespace.pm
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/lib/XUnit/LoadNamespace.pm	                        (rev 0)
+++ DBIx-Class/0.08/branches/test_class/t/lib/XUnit/LoadNamespace.pm	2009-11-15 23:43:17 UTC (rev 7913)
@@ -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__

Added: DBIx-Class/0.08/branches/test_class/t/lib/XUnit.pm
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/lib/XUnit.pm	                        (rev 0)
+++ DBIx-Class/0.08/branches/test_class/t/lib/XUnit.pm	2009-11-15 23:43:17 UTC (rev 7913)
@@ -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__

Added: DBIx-Class/0.08/branches/test_class/t/xunit.t
===================================================================
--- DBIx-Class/0.08/branches/test_class/t/xunit.t	                        (rev 0)
+++ DBIx-Class/0.08/branches/test_class/t/xunit.t	2009-11-15 23:43:17 UTC (rev 7913)
@@ -0,0 +1,8 @@
+#!/usr/bin/perl -T
+
+use strict;
+use warnings;
+
+use lib qw( t/lib );
+
+use Test::Class::Load 't/lib/XUnit';




More information about the Bast-commits mailing list