t/049_run_time_role_composition.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 20;
   7
   8 use Scalar::Util qw(blessed);
   9
  10 BEGIN {
  11     use_ok('Moose');
  12 }
  13
  14 =pod
  15
  16 This test can be used as a basis for the runtime role composition.
  17 Apparently it is not as simple as just making an anon class. One of
  18 the problems is the way that anon classes are DESTROY-ed, which is
  19 not very compatible with how instances are dealt with.
  20
  21 =cut
  22
  23 {
  24     package Bark;
  25     use Moose::Role;
  26
  27     sub talk { 'woof' }
  28
  29     package Sleeper;
  30     use Moose::Role;
  31
  32     sub sleep { 'snore' }
  33     sub talk { 'zzz' }
  34
  35     package My::Class;
  36     use Moose;
  37
  38     sub sleep { 'nite-nite' }
  39 }
  40
  41 my $obj = My::Class->new;
  42 ok(!$obj->can( 'talk' ), "... the role is not composed yet");
  43
  44
  45 {
  46     isa_ok($obj, 'My::Class');
  47
  48     ok(!$obj->does('Bark'), '... we do not do any roles yet');
  49
  50     Bark->meta->apply($obj);
  51
  52     ok($obj->does('Bark'), '... we now do the Bark role');
  53     ok(!My::Class->does('Bark'), '... the class does not do the Bark role');
  54
  55     isa_ok($obj, 'My::Class');
  56     isnt(blessed($obj), 'My::Class', '... but it is no longer blessed into My::Class');
  57
  58     ok(!My::Class->can('talk'), "... the role is not composed at the class level");
  59     ok($obj->can('talk'), "... the role is now composed at the object level");
  60
  61     is($obj->talk, 'woof', '... got the right return value for the newly composed method');
  62 }
  63
  64 {
  65     is($obj->sleep, 'nite-nite', '... the original method responds as expected');
  66
  67     ok(!$obj->does('Sleeper'), '... we do not do the Sleeper role');
  68
  69     Sleeper->meta->apply($obj);
  70
  71     ok($obj->does('Bark'), '... we still do the Bark role');
  72     ok($obj->does('Sleeper'), '... we now do the Sleeper role too');
  73
  74     ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role');
  75
  76     isa_ok($obj, 'My::Class');
  77
  78     is(My::Class->sleep, 'nite-nite', '... the original method still responds as expected');
  79
  80     is($obj->sleep, 'snore', '... got the right return value for the newly composed method');
  81     is($obj->talk, 'zzz', '... got the right return value for the newly composed method');
  82 }