t/044-attribute-metaclass.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 2;
   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 Klass;
  41     use Mouse;
  42
  43     has 'i' => (
  44         metaclass => 'Number',
  45         is => 'rw',
  46         isa => 'Int',
  47         provides => {
  48             'add' => 'add_number'
  49         },
  50     );
  51 };
  52
  53 can_ok 'Klass', 'add_number';
  54 my $k = Klass->new(i=>3);
  55 $k->add_number(4);
  56 is $k->i, 7;
  57