xt/extra/c3_mro.t

   1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
   2
   3 use warnings;
   4 use strict;
   5
   6 use Test::More;
   7 use DBICTest;
   8 use DBIx::Class::Optional::Dependencies;
   9 use DBIx::Class::_Util 'uniq';
  10
  11 my @global_ISA_tail = qw(
  12   DBIx::Class
  13   DBIx::Class::Componentised
  14   Class::C3::Componentised
  15   DBIx::Class::AccessorGroup
  16   DBIx::Class::MethodAttributes
  17   Class::Accessor::Grouped
  18 );
  19
  20 {
  21   package AAA;
  22
  23   use base "DBIx::Class::Core";
  24   use mro 'c3';
  25 }
  26
  27 {
  28   package BBB;
  29
  30   use base 'AAA';
  31
  32   #Injecting a direct parent.
  33   __PACKAGE__->inject_base( __PACKAGE__, 'AAA' );
  34 }
  35
  36 {
  37   package CCC;
  38
  39   use base 'AAA';
  40
  41   #Injecting an indirect parent.
  42   __PACKAGE__->inject_base( __PACKAGE__, 'DBIx::Class::Core' );
  43 }
  44
  45 eval { mro::get_linear_isa('BBB'); };
  46 ok (! $@, "Correctly skipped injecting a direct parent of class BBB");
  47
  48 eval { mro::get_linear_isa('CCC'); };
  49 ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
  50
  51
  52 my $art = DBICTest->init_schema->resultset("Artist")->next;
  53
  54 check_ancestry($_) for uniq map
  55   { length ref $_ ? ref $_ : $_ }
  56   (
  57     $art,
  58     $art->result_source,
  59     $art->result_source->resultset,
  60     ( map
  61       { $_, $_->result_class, $_->resultset_class }
  62       map
  63         { $art->result_source->schema->source($_) }
  64         $art->result_source->schema->sources
  65     ),
  66     qw( AAA BBB CCC ),
  67     ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do {
  68       unshift @INC, 't/cdbi/testlib';
  69       map { eval "require $_" or die $@; $_ } qw(
  70         Film Lazy Actor ActorAlias ImplicitInflate
  71       );
  72     }),
  73   )
  74 ;
  75
  76 use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server;
  77
  78 is_deeply (
  79   mro::get_linear_isa('DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'),
  80   [qw/
  81     DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server
  82     DBIx::Class::Storage::DBI::Sybase
  83     DBIx::Class::Storage::DBI::MSSQL
  84     DBIx::Class::Storage::DBI::UniqueIdentifier
  85     DBIx::Class::Storage::DBI::IdentityInsert
  86     DBIx::Class::Storage::DBI
  87     DBIx::Class::Storage::DBIHacks
  88     DBIx::Class::Storage
  89   /, @global_ISA_tail],
  90   'Correctly ordered ISA of DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'
  91 );
  92
  93 my $storage = DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server->new;
  94 $storage->connect_info(['dbi:SQLite::memory:']); # determine_driver's init() connects for this subclass
  95 $storage->_determine_driver;
  96 is (
  97   $storage->can('sql_limit_dialect'),
  98   'DBIx::Class::Storage::DBI::MSSQL'->can('sql_limit_dialect'),
  99   'Correct method picked'
 100 );
 101
 102 if ( "$]" >= 5.010 ) {
 103   ok (! $INC{'Class/C3.pm'}, 'No Class::C3 loaded on perl 5.10+');
 104
 105   # Class::C3::Componentised loads MRO::Compat unconditionally to satisfy
 106   # the assumption that once Class::C3::X is loaded, so is Class::C3
 107   #ok (! $INC{'MRO/Compat.pm'}, 'No MRO::Compat loaded on perl 5.10+');
 108 }
 109
 110 sub check_ancestry {
 111   my $class = shift;
 112
 113   die "Expecting classname" if length ref $class;
 114
 115   my @linear_ISA = @{ mro::get_linear_isa($class) };
 116
 117   # something is *VERY* wrong, the splice below won't make it
 118   unless (@linear_ISA > @global_ISA_tail) {
 119     fail(
 120       "Unexpectedly shallow \@ISA for class '$class': "
 121     . join ', ', map { "'$_'" } @linear_ISA
 122     );
 123     return;
 124   }
 125
 126   is_deeply (
 127     [ splice @linear_ISA, ($#linear_ISA - $#global_ISA_tail) ],
 128     \@global_ISA_tail,
 129     "Correct end of \@ISA for '$class'"
 130   );
 131
 132   is(
 133     mro::get_mro($class),
 134     'c3',
 135     "Expected mro on class '$class' automatically set",
 136   );
 137 }
 138
 139 done_testing;