t/attributes/delegation_arg_aliasing.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5
   6 {
   7     package Foo;
   8     use Moose;
   9
  10     sub aliased {
  11         my $self = shift;
  12         $_[1] = $_[0];
  13     }
  14 }
  15
  16 {
  17     package HasFoo;
  18     use Moose;
  19
  20     has foo => (
  21         is  => 'ro',
  22         isa => 'Foo',
  23         handles => {
  24             foo_aliased => 'aliased',
  25             foo_aliased_curried => ['aliased', 'bar'],
  26         }
  27     );
  28 }
  29
  30 my $hasfoo = HasFoo->new(foo => Foo->new);
  31 my $x;
  32 $hasfoo->foo->aliased('foo', $x);
  33 is($x, 'foo', "direct aliasing works");
  34 undef $x;
  35 $hasfoo->foo_aliased('foo', $x);
  36 is($x, 'foo', "delegated aliasing works");
  37 undef $x;
  38 $hasfoo->foo_aliased_curried($x);
  39 is($x, 'bar', "delegated aliasing with currying works");
  40
  41 done_testing;