t/sub-and-handles.t

   1 use strictures 1;
   2 use Test::More;
   3
   4 {
   5    package DelegateBar;
   6
   7    use Moo;
   8
   9    sub bar { 'unextended!' }
  10
  11    package Does::DelegateToBar;
  12
  13    use Moo::Role;
  14
  15    has _barrer => (
  16       is => 'ro',
  17       default => sub { DelegateBar->new },
  18       handles => { _bar => 'bar' },
  19    );
  20
  21    sub get_barrer { $_[0]->_barrer }
  22
  23    package ConsumesDelegateToBar;
  24
  25    use Moo;
  26
  27    with 'Does::DelegateToBar';
  28
  29    has bong => ( is => 'ro' );
  30
  31    package Does::OverrideDelegate;
  32
  33    use Moo::Role;
  34
  35    sub _bar { 'extended' }
  36
  37    package A;
  38
  39    use Moo;
  40    extends 'ConsumesDelegateToBar';
  41    with 'Does::OverrideDelegate';
  42
  43    has '+_barrer' => ( is => 'rw' );
  44
  45    package B;
  46
  47    use Moo;
  48    extends 'ConsumesDelegateToBar';
  49
  50    sub _bar { 'extended' }
  51
  52    has '+_barrer' => ( is => 'rw' );
  53
  54    package D;
  55
  56    use Moo;
  57    extends 'ConsumesDelegateToBar';
  58
  59    sub _bar { 'extended' }
  60
  61    has '+_barrer' => (
  62       is => 'rw',
  63       handles => { _baz => 'bar' },
  64    );
  65    package C;
  66
  67    use Moo;
  68    extends 'ConsumesDelegateToBar';
  69    with 'Does::OverrideDelegate';
  70
  71    has '+_barrer' => (
  72       is => 'rw',
  73       handles => { _baz => 'bar' },
  74    );
  75 }
  76
  77 is(A->new->_bar, 'extended', 'overriding delegate method with role works');
  78 is(D->new->_bar, 'extended', '... even when you specify other delegates in subclass');
  79 is(D->new->_baz, 'unextended!', '... and said other delegate still works');
  80 is(B->new->_bar, 'extended', 'overriding delegate method directly works');
  81 is(C->new->_bar, 'extended', '... even when you specify other delegates in subclass');
  82 is(C->new->_baz, 'unextended!', '... and said other delegate still works');
  83
  84 done_testing;
  85