Commit | Line | Data |
7b42fc96 |
1 | #!/usr/bin/env perl |
2 | package MooseX::Role::Parameterized; |
fc4a95b6 |
3 | use Moose ( |
4 | extends => { -as => 'moose_extends' }, |
5 | qw/around confess/, |
6 | ); |
7 | |
8 | use Carp 'croak'; |
7b42fc96 |
9 | use Moose::Role (); |
fc4a95b6 |
10 | moose_extends 'Moose::Exporter'; |
7b42fc96 |
11 | |
d93bd54d |
12 | use MooseX::Role::Parameterized::Meta::Role::Parameterizable; |
5b82ffb1 |
13 | |
a457ed60 |
14 | our $CURRENT_METACLASS; |
4534bdce |
15 | |
5b82ffb1 |
16 | __PACKAGE__->setup_import_methods( |
209e00d2 |
17 | with_caller => ['parameter', 'role', 'method'], |
eac6d242 |
18 | as_is => ['has', 'with', 'extends', 'requires', 'augment', 'inner'], |
19af6e75 |
19 | ); |
20 | |
21 | sub parameter { |
22 | my $caller = shift; |
bd3dd853 |
23 | my $names = shift; |
24 | |
25 | $names = [$names] if !ref($names); |
26 | |
27 | for my $name (@$names) { |
9a21e637 |
28 | Class::MOP::Class->initialize($caller)->add_parameter($name, @_); |
bd3dd853 |
29 | } |
19af6e75 |
30 | } |
7b42fc96 |
31 | |
5b82ffb1 |
32 | sub role { |
33 | my $caller = shift; |
34 | my $role_generator = shift; |
9a21e637 |
35 | Class::MOP::Class->initialize($caller)->role_generator($role_generator); |
5b82ffb1 |
36 | } |
37 | |
7b42fc96 |
38 | sub init_meta { |
39 | my $self = shift; |
40 | |
41 | return Moose::Role->init_meta(@_, |
d93bd54d |
42 | metaclass => 'MooseX::Role::Parameterized::Meta::Role::Parameterizable', |
7b42fc96 |
43 | ); |
44 | } |
45 | |
5b82ffb1 |
46 | # give role a (&) prototype |
47 | around _make_wrapper => sub { |
48 | my $orig = shift; |
49 | my ($self, $caller, $sub, $fq_name) = @_; |
50 | |
51 | if ($fq_name =~ /::role$/) { |
52 | return sub (&) { $sub->($caller, @_) }; |
53 | } |
54 | |
55 | return $orig->(@_); |
56 | }; |
57 | |
a457ed60 |
58 | sub has { |
59 | confess "has must be called within the role { ... } block." |
60 | unless $CURRENT_METACLASS; |
61 | |
209e00d2 |
62 | my $names = shift; |
a457ed60 |
63 | $names = [$names] if !ref($names); |
64 | |
65 | for my $name (@$names) { |
66 | $CURRENT_METACLASS->add_attribute($name, @_); |
67 | } |
68 | } |
69 | |
209e00d2 |
70 | sub method { |
71 | confess "method must be called within the role { ... } block." |
72 | unless $CURRENT_METACLASS; |
73 | |
74 | my $caller = shift; |
75 | my $name = shift; |
76 | my $body = shift; |
77 | |
31c69f88 |
78 | my $method = $CURRENT_METACLASS->method_metaclass->wrap( |
209e00d2 |
79 | package_name => $caller, |
80 | name => $name, |
81 | body => $body, |
82 | ); |
83 | |
84 | $CURRENT_METACLASS->add_method($name => $method); |
85 | } |
86 | |
d55c8861 |
87 | sub with { |
88 | confess "with must be called within the role { ... } block." |
89 | unless $CURRENT_METACLASS; |
90 | Moose::Util::apply_all_roles($CURRENT_METACLASS, @_); |
91 | } |
92 | |
eac6d242 |
93 | sub requires { |
94 | confess "requires must be called within the role { ... } block." |
95 | unless $CURRENT_METACLASS; |
96 | croak "Must specify at least one method" unless @_; |
97 | $CURRENT_METACLASS->add_required_methods(@_); |
98 | } |
99 | |
fc4a95b6 |
100 | sub extends { croak "Roles do not currently support 'extends'" } |
101 | |
102 | sub inner { croak "Roles cannot support 'inner'" } |
103 | |
104 | sub augment { croak "Roles cannot support 'augment'" } |
105 | |
7b42fc96 |
106 | 1; |
107 | |