t/990_deprecated/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     around 'canonicalize_args' => sub {
  35         my ($next, $self, $name, %args) = @_;
  36
  37         %args = $next->($self, $name, %args);
  38         $args{is}  = 'rw'  unless exists $args{is};
  39
  40         return %args;
  41     };
  42
  43     package # hide me from search.cpan.org
  44         Mouse::Meta::Attribute::Custom::Number;
  45     sub register_implementation { 'MouseX::AttributeHelpers::Number' }
  46
  47     1;
  48
  49     package Klass;
  50     use Mouse;
  51
  52     has 'number' => (
  53         metaclass => 'Number',
  54         isa => 'Int',
  55         provides => {
  56             'add' => 'add_number'
  57         },
  58     );
  59 };
  60
  61 can_ok 'Klass', 'add_number', 'number';
  62 my $k = Klass->new(number => 3);
  63 $k->add_number(4);
  64 is $k->number, 7;
  65