Commit | Line | Data |
a09601ab |
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 | |
346a3ab8 |
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 | }; |
434ca269 |
42 | |
a09601ab |
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 | |
434ca269 |
52 | has 'number' => ( |
a09601ab |
53 | metaclass => 'Number', |
a09601ab |
54 | isa => 'Int', |
55 | provides => { |
56 | 'add' => 'add_number' |
57 | }, |
58 | ); |
59 | }; |
60 | |
434ca269 |
61 | can_ok 'Klass', 'add_number', 'number'; |
134daa67 |
62 | my $k = Klass->new(number => 3); |
a09601ab |
63 | $k->add_number(4); |
434ca269 |
64 | is $k->number, 7; |
a09601ab |
65 | |