t/030_roles/010_run_time_role_composition.t

   1 #!/usr/bin/perl
   2 # This is automatically generated by author/import-moose-test.pl.
   3 # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
   4 use t::lib::MooseCompat;
   5
   6 use strict;
   7 use warnings;
   8
   9 use Test::More;
  10 $TODO = q{Mouse is not yet completed};
  11
  12 use Scalar::Util qw(blessed);
  13
  14
  15 =pod
  16
  17 This test can be used as a basis for the runtime role composition.
  18 Apparently it is not as simple as just making an anon class. One of
  19 the problems is the way that anon classes are DESTROY-ed, which is
  20 not very compatible with how instances are dealt with.
  21
  22 =cut
  23
  24 {
  25     package Bark;
  26     use Mouse::Role;
  27
  28     sub talk { 'woof' }
  29
  30     package Sleeper;
  31     use Mouse::Role;
  32
  33     sub sleep { 'snore' }
  34     sub talk { 'zzz' }
  35
  36     package My::Class;
  37     use Mouse;
  38
  39     sub sleep { 'nite-nite' }
  40 }
  41
  42 my $obj = My::Class->new;
  43 isa_ok($obj, 'My::Class');
  44
  45 my $obj2 = My::Class->new;
  46 isa_ok($obj2, 'My::Class');
  47
  48 {
  49     ok(!$obj->can( 'talk' ), "... the role is not composed yet");
  50
  51     ok(!$obj->does('Bark'), '... we do not do any roles yet');
  52
  53     Bark->meta->apply($obj);
  54
  55     ok($obj->does('Bark'), '... we now do the Bark role');
  56     ok(!My::Class->does('Bark'), '... the class does not do the Bark role');
  57
  58     isa_ok($obj, 'My::Class');
  59     isnt(blessed($obj), 'My::Class', '... but it is no longer blessed into My::Class');
  60
  61     ok(!My::Class->can('talk'), "... the role is not composed at the class level");
  62     ok($obj->can('talk'), "... the role is now composed at the object level");
  63
  64     is($obj->talk, 'woof', '... got the right return value for the newly composed method');
  65 }
  66
  67 {
  68     ok(!$obj2->does('Sleeper'), '... we do not do any roles yet');
  69
  70     Sleeper->meta->apply($obj2);
  71
  72     ok($obj2->does('Sleeper'), '... we now do the Sleeper role');
  73     isnt(blessed($obj), blessed($obj2), '... they DO NOT share the same anon-class/role thing');
  74 }
  75
  76 {
  77     is($obj->sleep, 'nite-nite', '... the original method responds as expected');
  78
  79     ok(!$obj->does('Sleeper'), '... we do not do the Sleeper role');
  80
  81     Sleeper->meta->apply($obj);
  82
  83     ok($obj->does('Bark'), '... we still do the Bark role');
  84     ok($obj->does('Sleeper'), '... we now do the Sleeper role too');
  85
  86     ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role');
  87
  88     isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing');
  89
  90     isa_ok($obj, 'My::Class');
  91
  92     is(My::Class->sleep, 'nite-nite', '... the original method still responds as expected');
  93
  94     is($obj->sleep, 'snore', '... got the right return value for the newly composed method');
  95     is($obj->talk, 'zzz', '... got the right return value for the newly composed method');
  96 }
  97
  98 {
  99     ok(!$obj2->does('Bark'), '... we do not do Bark yet');
 100
 101     Bark->meta->apply($obj2);
 102
 103     ok($obj2->does('Bark'), '... we now do the Bark role');
 104     isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing');
 105 }
 106
 107 # test that anon classes are equivalent after role composition in the same order
 108 {
 109     foreach ($obj, $obj2) {
 110         $_ = My::Class->new;
 111         Bark->meta->apply($_);
 112         Sleeper->meta->apply($_);
 113     }
 114     is(blessed($obj), blessed($obj2), '... they now share the same anon-class/role thing');
 115 }
 116
 117 done_testing;