t/990_deprecated/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     local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ };
   9
  10     package MouseX::AttributeHelpers::Number;
  11     use Mouse;
  12     extends 'Mouse::Meta::Attribute';
  13
  14     sub create {
  15         my ($self, @args) = @_;
  16         my $attr = $self->SUPER::create(@args);
  17         my %provides = %{$attr->{provides}};
  18         my $method_constructors = {
  19             add => sub {
  20                 my ($attr, $name) = @_;
  21                 return sub {
  22                     $_[0]->$name( $_[0]->$name() + $_[1])
  23                 };
  24             },
  25         };
  26         while (my ($name, $aliased) = each %provides) {
  27             $attr->associated_class->add_method(
  28                 $aliased => $method_constructors->{$name}->($attr, $attr->name)
  29             );
  30         }
  31         return $attr;
  32     };
  33
  34     package # hide me from search.cpan.org
  35         Mouse::Meta::Attribute::Custom::Number;
  36     sub register_implementation { 'MouseX::AttributeHelpers::Number' }
  37
  38     1;
  39
  40     package Foo;
  41     use Mouse::Role;
  42
  43     has 'i' => (
  44         metaclass => 'Number',
  45         is => 'rw',
  46         isa => 'Int',
  47         provides => {
  48             'add' => 'add_number'
  49         },
  50     );
  51     sub f_m {}
  52
  53     package Bar;
  54     use Mouse::Role;
  55
  56     has 'j' => (
  57         metaclass => 'Number',
  58         is => 'rw',
  59         isa => 'Int',
  60         provides => {
  61             'add' => 'add_number_j'
  62         },
  63     );
  64     sub b_m {}
  65
  66     package Klass1;
  67     use Mouse;
  68     with 'Foo';
  69
  70     package Klass2;
  71     use Mouse;
  72     with 'Foo', 'Bar';
  73
  74 };
  75
  76 {
  77     # normal
  78     can_ok 'Klass1', 'add_number';
  79     my $k = Klass1->new(i=>3);
  80     $k->add_number(4);
  81     is $k->i, 7;
  82 }
  83
  84 {
  85     # combine
  86     can_ok 'Klass2', 'f_m';
  87     can_ok 'Klass2', 'b_m';
  88     can_ok 'Klass2', 'add_number';
  89     can_ok 'Klass2', 'add_number_j';
  90     my $k = Klass2->new(i=>3);
  91     $k->add_number(4);
  92     is $k->i, 7;
  93 }
  94
  95