X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=xt%2Fextra%2Fc3_mro.t;h=398f51e48e2c0ec4fc8c6ed248da250b9180ae07;hb=92705f7f05161f7dba36d9b09dc6e893af7b2773;hp=0b7314c79b7304e185bbc70db98d97273c8db847;hpb=c26b30dee587fa008f7d956b61ae27c36ac7ec82;p=dbsrgits%2FDBIx-Class.git

diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t
index 0b7314c..398f51e 100644
--- a/xt/extra/c3_mro.t
+++ b/xt/extra/c3_mro.t
@@ -1,10 +1,26 @@
+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+
 use warnings;
 use strict;
 
 use Test::More;
+use DBICTest;
+use DBIx::Class::Optional::Dependencies;
+
+my @global_ISA_tail = qw(
+  DBIx::Class
+  DBIx::Class::Componentised
+  Class::C3::Componentised
+  DBIx::Class::AccessorGroup
+  DBIx::Class::MethodAttributes
+  Class::Accessor::Grouped
+);
 
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used (pulls in MRO::Compat if needed)
+is(
+  mro::get_mro($_),
+  'c3',
+  "Correct mro on base class '$_'",
+) for grep { $_ =~ /^DBIx::Class/ } @global_ISA_tail;
 
 {
   package AAA;
@@ -36,6 +52,27 @@ ok (! $@, "Correctly skipped injecting a direct parent of class BBB");
 eval { mro::get_linear_isa('CCC'); };
 ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
 
+
+my $art = DBICTest->init_schema->resultset("Artist")->next;
+
+check_ancestry($_) for (
+  ref( $art ),
+  ref( $art->result_source ),
+  ref( $art->result_source->resultset ),
+  ref( $art->result_source->schema ),
+  ( map
+    { ref $art->result_source->schema->source($_) }
+    $art->result_source->schema->sources
+  ),
+  qw( AAA BBB CCC ),
+  ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do {
+    unshift @INC, 't/cdbi/testlib';
+    map { eval "require $_" or die $@; $_ } qw(
+      Film Lazy Actor ActorAlias ImplicitInflate
+    );
+  }),
+);
+
 use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server;
 
 is_deeply (
@@ -49,12 +86,7 @@ is_deeply (
     DBIx::Class::Storage::DBI
     DBIx::Class::Storage::DBIHacks
     DBIx::Class::Storage
-    DBIx::Class
-    DBIx::Class::Componentised
-    Class::C3::Componentised
-    DBIx::Class::AccessorGroup
-    Class::Accessor::Grouped
-  /],
+  /, @global_ISA_tail],
   'Correctly ordered ISA of DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'
 );
 
@@ -67,7 +99,7 @@ is (
   'Correct method picked'
 );
 
-if ($] >= 5.010) {
+if ( "$]" >= 5.010 ) {
   ok (! $INC{'Class/C3.pm'}, 'No Class::C3 loaded on perl 5.10+');
 
   # Class::C3::Componentised loads MRO::Compat unconditionally to satisfy
@@ -75,4 +107,37 @@ if ($] >= 5.010) {
   #ok (! $INC{'MRO/Compat.pm'}, 'No MRO::Compat loaded on perl 5.10+');
 }
 
+sub check_ancestry {
+  my $class = shift;
+
+  die "Expecting classname" if length ref $class;
+
+  my @linear_ISA = @{ mro::get_linear_isa($class) };
+
+  # something is *VERY* wrong, the splice below won't make it
+  unless (@linear_ISA > @global_ISA_tail) {
+    fail(
+      "Unexpectedly shallow \@ISA for class '$class': "
+    . join ', ', map { "'$_'" } @linear_ISA
+    );
+    return;
+  }
+
+  is_deeply (
+    [ splice @linear_ISA, ($#linear_ISA - $#global_ISA_tail) ],
+    \@global_ISA_tail,
+    "Correct end of \@ISA for '$class'"
+  );
+
+  # check the remainder
+  for my $c (@linear_ISA) {
+    # nothing to see there
+    next if $c =~ /^DBICTest::/;
+
+    next if mro::get_mro($c) eq 'c3';
+
+    fail( "Incorrect mro '@{[ mro::get_mro($c) ]}' on '$c' (parent of '$class')" );
+  }
+}
+
 done_testing;