Commit | Line | Data |
7b42fc96 |
1 | #!/usr/bin/env perl |
2 | package MooseX::Role::Parameterized; |
a457ed60 |
3 | use Moose qw/extends around confess/; |
7b42fc96 |
4 | use Moose::Role (); |
5b82ffb1 |
5 | extends 'Moose::Exporter'; |
7b42fc96 |
6 | |
d93bd54d |
7 | use MooseX::Role::Parameterized::Meta::Role::Parameterizable; |
5b82ffb1 |
8 | |
a457ed60 |
9 | our $CURRENT_METACLASS; |
4534bdce |
10 | |
5b82ffb1 |
11 | __PACKAGE__->setup_import_methods( |
209e00d2 |
12 | with_caller => ['parameter', 'role', 'method'], |
13 | as_is => ['has'], |
19af6e75 |
14 | ); |
15 | |
16 | sub parameter { |
17 | my $caller = shift; |
bd3dd853 |
18 | my $names = shift; |
19 | |
20 | $names = [$names] if !ref($names); |
21 | |
22 | for my $name (@$names) { |
9a21e637 |
23 | Class::MOP::Class->initialize($caller)->add_parameter($name, @_); |
bd3dd853 |
24 | } |
19af6e75 |
25 | } |
7b42fc96 |
26 | |
5b82ffb1 |
27 | sub role { |
28 | my $caller = shift; |
29 | my $role_generator = shift; |
9a21e637 |
30 | Class::MOP::Class->initialize($caller)->role_generator($role_generator); |
5b82ffb1 |
31 | } |
32 | |
7b42fc96 |
33 | sub init_meta { |
34 | my $self = shift; |
35 | |
36 | return Moose::Role->init_meta(@_, |
d93bd54d |
37 | metaclass => 'MooseX::Role::Parameterized::Meta::Role::Parameterizable', |
7b42fc96 |
38 | ); |
39 | } |
40 | |
5b82ffb1 |
41 | # give role a (&) prototype |
42 | around _make_wrapper => sub { |
43 | my $orig = shift; |
44 | my ($self, $caller, $sub, $fq_name) = @_; |
45 | |
46 | if ($fq_name =~ /::role$/) { |
47 | return sub (&) { $sub->($caller, @_) }; |
48 | } |
49 | |
50 | return $orig->(@_); |
51 | }; |
52 | |
a457ed60 |
53 | sub has { |
54 | confess "has must be called within the role { ... } block." |
55 | unless $CURRENT_METACLASS; |
56 | |
209e00d2 |
57 | my $names = shift; |
a457ed60 |
58 | $names = [$names] if !ref($names); |
59 | |
60 | for my $name (@$names) { |
61 | $CURRENT_METACLASS->add_attribute($name, @_); |
62 | } |
63 | } |
64 | |
209e00d2 |
65 | sub method { |
66 | confess "method must be called within the role { ... } block." |
67 | unless $CURRENT_METACLASS; |
68 | |
69 | my $caller = shift; |
70 | my $name = shift; |
71 | my $body = shift; |
72 | |
73 | my $method = Moose::Meta::Method->wrap( |
74 | package_name => $caller, |
75 | name => $name, |
76 | body => $body, |
77 | ); |
78 | |
79 | $CURRENT_METACLASS->add_method($name => $method); |
80 | } |
81 | |
7b42fc96 |
82 | 1; |
83 | |