t/basics/inner_and_augment.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Fatal;
   8
   9
  10 {
  11     package Foo;
  12     use Moose;
  13
  14     sub foo { 'Foo::foo(' . (inner() || '') . ')' }
  15     sub bar { 'Foo::bar(' . (inner() || '') . ')' }
  16     sub baz { 'Foo::baz(' . (inner() || '') . ')' }
  17
  18     package Bar;
  19     use Moose;
  20
  21     extends 'Foo';
  22
  23     augment foo => sub { 'Bar::foo(' . (inner() || '') . ')' };
  24     augment bar => sub { 'Bar::bar' };
  25
  26     no Moose; # ensure inner() still works after unimport
  27
  28     package Baz;
  29     use Moose;
  30
  31     extends 'Bar';
  32
  33     augment foo => sub { 'Baz::foo' };
  34     augment baz => sub { 'Baz::baz' };
  35
  36     # this will actually never run,
  37     # because Bar::bar does not call inner()
  38     augment bar => sub { 'Baz::bar' };
  39 }
  40
  41 my $baz = Baz->new();
  42 isa_ok($baz, 'Baz');
  43 isa_ok($baz, 'Bar');
  44 isa_ok($baz, 'Foo');
  45
  46 is($baz->foo(), 'Foo::foo(Bar::foo(Baz::foo))', '... got the right value from &foo');
  47 is($baz->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar');
  48 is($baz->baz(), 'Foo::baz(Baz::baz)', '... got the right value from &baz');
  49
  50 my $bar = Bar->new();
  51 isa_ok($bar, 'Bar');
  52 isa_ok($bar, 'Foo');
  53
  54 is($bar->foo(), 'Foo::foo(Bar::foo())', '... got the right value from &foo');
  55 is($bar->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar');
  56 is($bar->baz(), 'Foo::baz()', '... got the right value from &baz');
  57
  58 my $foo = Foo->new();
  59 isa_ok($foo, 'Foo');
  60
  61 is($foo->foo(), 'Foo::foo()', '... got the right value from &foo');
  62 is($foo->bar(), 'Foo::bar()', '... got the right value from &bar');
  63 is($foo->baz(), 'Foo::baz()', '... got the right value from &baz');
  64
  65 # test saved state when crossing objects
  66
  67 {
  68     package X;
  69     use Moose;
  70     has name => (is => 'rw');
  71     sub run {
  72         "$_[0]->{name}.X", inner()
  73     }
  74
  75     package Y;
  76     use Moose;
  77     extends 'X';
  78     augment 'run' => sub {
  79         "$_[0]->{name}.Y", ($_[1] ? $_[1]->() : ()), inner();
  80     };
  81
  82     package Z;
  83     use Moose;
  84     extends 'Y';
  85     augment 'run' => sub {
  86         "$_[0]->{name}.Z"
  87     }
  88 }
  89
  90 is('a.X a.Y b.X b.Y b.Z a.Z',
  91    do {
  92        my $a = Z->new(name => 'a');
  93        my $b = Z->new(name => 'b');
  94        join(' ', $a->run(sub { $b->run }))
  95    },
  96    'State is saved when cross-calling augmented methods on different objects');
  97
  98 # some error cases
  99
 100 {
 101     package Bling;
 102     use Moose;
 103
 104     sub bling { 'Bling::bling' }
 105
 106     package Bling::Bling;
 107     use Moose;
 108
 109     extends 'Bling';
 110
 111     sub bling { 'Bling::bling' }
 112
 113     ::isnt( ::exception {
 114         augment 'bling' => sub {};
 115     }, undef, '... cannot augment a method which has a local equivalent' );
 116
 117 }
 118
 119 done_testing;