Commit | Line | Data |
a09601ab |
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 | |