t/042_apply_role.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 33;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     use_ok('Moose::Role');
  11 }
  12
  13
  14
  15 {
  16     package FooRole;
  17     use Moose::Role;
  18
  19     has 'bar' => (is => 'rw', isa => 'FooClass');
  20     has 'baz' => (is => 'ro');
  21
  22     sub goo { 'FooRole::goo' }
  23     sub foo { 'FooRole::foo' }
  24
  25     package BarClass;
  26     use Moose;
  27
  28     sub boo { 'BarClass::boo' }
  29     sub foo { 'BarClass::foo' }  # << the role overrides this ...
  30
  31     package FooClass;
  32     use Moose;
  33
  34     extends 'BarClass';
  35        with 'FooRole';
  36
  37     sub goo { 'FooClass::goo' }  # << overrides the one from the role ...
  38 }
  39
  40 my $foo_class_meta = FooClass->meta;
  41 isa_ok($foo_class_meta, 'Moose::Meta::Class');
  42
  43 dies_ok {
  44     $foo_class_meta->does_role()
  45 } '... does_role requires a role name';
  46
  47 dies_ok {
  48     $foo_class_meta->apply_role()
  49 } '... apply_role requires a role';
  50
  51 dies_ok {
  52     $foo_class_meta->apply_role(bless({} => 'Fail'))
  53 } '... apply_role requires a role';
  54
  55 ok($foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole');
  56 ok(!$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole');
  57
  58 foreach my $method_name (qw(bar baz foo goo)) {
  59     ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name);
  60 }
  61
  62 foreach my $attr_name (qw(bar baz)) {
  63     ok($foo_class_meta->has_attribute($attr_name), '... FooClass has the attribute ' . $attr_name);
  64 }
  65
  66 can_ok('FooClass', 'does');
  67 ok(FooClass->does('FooRole'), '... the FooClass does FooRole');
  68 ok(!FooClass->does('OtherRole'), '... the FooClass does not do OtherRole');
  69
  70 my $foo = FooClass->new();
  71 isa_ok($foo, 'FooClass');
  72
  73 can_ok($foo, 'does');
  74 ok($foo->does('FooRole'), '... an instance of FooClass does FooRole');
  75 ok(!$foo->does('OtherRole'), '... and instance of FooClass does not do OtherRole');
  76
  77 can_ok($foo, 'bar');
  78 can_ok($foo, 'baz');
  79 can_ok($foo, 'foo');
  80 can_ok($foo, 'goo');
  81
  82 is($foo->foo, 'FooRole::foo', '... got the right value of foo');
  83 is($foo->goo, 'FooClass::goo', '... got the right value of goo');
  84
  85 ok(!defined($foo->baz), '... $foo->baz is undefined');
  86 ok(!defined($foo->bar), '... $foo->bar is undefined');
  87
  88 dies_ok {
  89     $foo->baz(1)
  90 } '... baz is a read-only accessor';
  91
  92 dies_ok {
  93     $foo->bar(1)
  94 } '... bar is a read-write accessor with a type constraint';
  95
  96 my $foo2 = FooClass->new();
  97 isa_ok($foo2, 'FooClass');
  98
  99 lives_ok {
 100     $foo->bar($foo2)
 101 } '... bar is a read-write accessor with a type constraint';
 102
 103 is($foo->bar, $foo2, '... got the right value for bar now');
 104
 105