t/001_mouse/067-traits.t

   1 #!perl
   2 use strict;
   3 use warnings;
   4
   5 use Test::More;
   6
   7 use Test::Mouse qw(does_ok);
   8
   9 BEGIN{ $SIG{__WARN__} = \&Carp::confess }
  10
  11 BEGIN {
  12     package MyMouseX::Foo::Method;
  13     use Mouse::Role;
  14
  15     sub foo_method {}
  16
  17     package MyMouseX::Foo::Class;
  18     use Mouse::Role;
  19
  20     sub foo_class {}
  21
  22     package MyMouseX::Bar::Method;
  23     use Mouse::Role;
  24
  25     sub bar {}
  26
  27     package MyMouseX::Bar::Class;
  28     use Mouse::Role;
  29
  30     sub bar_class {}
  31 }
  32
  33 BEGIN {
  34     package MyMouseX::Foo;
  35     use Mouse::Exporter;
  36     use Mouse::Util::MetaRole;
  37
  38     Mouse::Exporter->setup_import_methods(
  39         also => 'Mouse',
  40     );
  41     sub init_meta {
  42         my(undef, %options) = @_;
  43
  44         my $meta = Mouse->init_meta(%options);
  45         Mouse::Util::MetaRole::apply_metaroles(
  46             for             => $options{for_class},
  47             class_metaroles => {
  48                 class  => ['MyMouseX::Foo::Class'],
  49                 method => ['MyMouseX::Foo::Method'],
  50             },
  51         );
  52     }
  53
  54     $INC{'MyMouseX/Foo.pm'} = __FILE__;
  55
  56     package MyMouseX::Bar;
  57     use Mouse::Exporter;
  58     use Mouse::Util::MetaRole;
  59
  60     Mouse::Exporter->setup_import_methods(
  61         also => 'Mouse',
  62     );
  63     sub init_meta {
  64         my(undef, %options) = @_;
  65
  66         my $meta = Mouse->init_meta(%options);
  67         Mouse::Util::MetaRole::apply_metaroles(
  68             for             => $options{for_class},
  69             class_metaroles => {
  70                 class  => ['MyMouseX::Bar::Class'],
  71                 method => ['MyMouseX::Bar::Method'],
  72             },
  73         );
  74     }
  75
  76     $INC{'MyMouseX/Bar.pm'} = __FILE__;
  77 }
  78 {
  79     package ClassA;
  80     use MyMouseX::Foo;
  81
  82     sub a {}
  83
  84     package ClassB;
  85     use MyMouseX::Bar;
  86
  87     sub b {}
  88
  89     package ClassC;
  90     use Mouse;
  91
  92     #extends qw(ClassB ClassA);
  93     extends qw(ClassA);
  94
  95     sub c {}
  96 }
  97
  98 does_ok(ClassA->meta,                  'MyMouseX::Foo::Class');
  99 does_ok(ClassA->meta->get_method('a'), 'MyMouseX::Foo::Method');
 100
 101 does_ok(ClassB->meta,                  'MyMouseX::Bar::Class');
 102 does_ok(ClassB->meta->get_method('b'), 'MyMouseX::Bar::Method');
 103
 104 # for ClassC
 105
 106 does_ok(ClassC->meta,                  'MyMouseX::Foo::Class');
 107
 108 {
 109     local $TODO = 'Metaclass incompatibility is not completed';
 110     does_ok(ClassC->meta->get_method('c'), 'MyMouseX::Foo::Method');
 111 }
 112 #does_ok(ClassC->meta,                  'MyMouseX::Bar::Class');
 113 #does_ok(ClassC->meta->get_method('c'), 'MyMouseX::Bar::Method');
 114
 115 done_testing;