t/001_mouse/047-attribute-metaclass-role.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 7;
   5 use lib 't/lib';
   6
   7 do {
   8     package MouseX::AttributeHelpers::Number;
   9     use Mouse;
  10     extends 'Mouse::Meta::Attribute';
  11
  12     has provides => (
  13         is => 'rw',
  14         isa => 'HashRef',
  15     );
  16
  17     after 'install_accessors' => sub{
  18         my ($attr) = @_;
  19
  20         my %provides = %{$attr->{provides}};
  21         my $method_constructors = {
  22             add => sub {
  23                 my ($attr, $name) = @_;
  24                 return sub {
  25                     $_[0]->$name( $_[0]->$name() + $_[1])
  26                 };
  27             },
  28         };
  29         while (my ($name, $aliased) = each %provides) {
  30             $attr->associated_class->add_method(
  31                 $aliased => $method_constructors->{$name}->($attr, $attr->name)
  32             );
  33         }
  34         return $attr;
  35     };
  36
  37     package
  38         Mouse::Meta::Attribute::Custom::MyNumber;
  39     sub register_implementation { 'MouseX::AttributeHelpers::Number' }
  40
  41     1;
  42
  43     package Foo;
  44     use Mouse::Role;
  45
  46     has 'i' => (
  47         metaclass => 'MyNumber',
  48         is => 'rw',
  49         isa => 'Int',
  50         provides => {
  51             'add' => 'add_number'
  52         },
  53     );
  54     sub f_m {}
  55
  56     package Bar;
  57     use Mouse::Role;
  58
  59     has 'j' => (
  60         metaclass => 'MyNumber',
  61         is => 'rw',
  62         isa => 'Int',
  63         provides => {
  64             'add' => 'add_number_j'
  65         },
  66     );
  67     sub b_m {}
  68
  69     package Klass1;
  70     use Mouse;
  71     with 'Foo';
  72
  73     package Klass2;
  74     use Mouse;
  75     with 'Foo', 'Bar';
  76
  77 };
  78
  79 {
  80     # normal
  81     can_ok 'Klass1', 'add_number';
  82     my $k = Klass1->new(i=>3);
  83     $k->add_number(4);
  84     is $k->i, 7;
  85 }
  86
  87 {
  88     # combine
  89     can_ok 'Klass2', 'f_m';
  90     can_ok 'Klass2', 'b_m';
  91     can_ok 'Klass2', 'add_number';
  92     can_ok 'Klass2', 'add_number_j';
  93     my $k = Klass2->new(i=>3);
  94     $k->add_number(4);
  95     is $k->i, 7;
  96 }
  97
  98