Commit | Line | Data |
7b42fc96 |
1 | #!/usr/bin/env perl |
2 | package MooseX::Role::Parameterized; |
fc4a95b6 |
3 | use Moose ( |
4 | extends => { -as => 'moose_extends' }, |
03c4551d |
5 | around => { -as => 'moose_around' }, |
2293e5f1 |
6 | qw/confess blessed/, |
fc4a95b6 |
7 | ); |
8 | |
9 | use Carp 'croak'; |
7b42fc96 |
10 | use Moose::Role (); |
fc4a95b6 |
11 | moose_extends 'Moose::Exporter'; |
7b42fc96 |
12 | |
d93bd54d |
13 | use MooseX::Role::Parameterized::Meta::Role::Parameterizable; |
5b82ffb1 |
14 | |
a457ed60 |
15 | our $CURRENT_METACLASS; |
4534bdce |
16 | |
5b82ffb1 |
17 | __PACKAGE__->setup_import_methods( |
209e00d2 |
18 | with_caller => ['parameter', 'role', 'method'], |
2293e5f1 |
19 | as_is => ['has', 'with', 'extends', 'requires', 'excludes', 'augment', 'inner', 'before', 'after', 'around', 'super', 'override', 'confess', 'blessed'], |
19af6e75 |
20 | ); |
21 | |
22 | sub parameter { |
23 | my $caller = shift; |
bd3dd853 |
24 | my $names = shift; |
25 | |
26 | $names = [$names] if !ref($names); |
27 | |
28 | for my $name (@$names) { |
9a21e637 |
29 | Class::MOP::Class->initialize($caller)->add_parameter($name, @_); |
bd3dd853 |
30 | } |
19af6e75 |
31 | } |
7b42fc96 |
32 | |
5b82ffb1 |
33 | sub role { |
34 | my $caller = shift; |
35 | my $role_generator = shift; |
9a21e637 |
36 | Class::MOP::Class->initialize($caller)->role_generator($role_generator); |
5b82ffb1 |
37 | } |
38 | |
7b42fc96 |
39 | sub init_meta { |
40 | my $self = shift; |
41 | |
42 | return Moose::Role->init_meta(@_, |
d93bd54d |
43 | metaclass => 'MooseX::Role::Parameterized::Meta::Role::Parameterizable', |
7b42fc96 |
44 | ); |
45 | } |
46 | |
5b82ffb1 |
47 | # give role a (&) prototype |
03c4551d |
48 | moose_around _make_wrapper => sub { |
5b82ffb1 |
49 | my $orig = shift; |
50 | my ($self, $caller, $sub, $fq_name) = @_; |
51 | |
52 | if ($fq_name =~ /::role$/) { |
53 | return sub (&) { $sub->($caller, @_) }; |
54 | } |
55 | |
56 | return $orig->(@_); |
57 | }; |
58 | |
a457ed60 |
59 | sub has { |
60 | confess "has must be called within the role { ... } block." |
61 | unless $CURRENT_METACLASS; |
62 | |
209e00d2 |
63 | my $names = shift; |
a457ed60 |
64 | $names = [$names] if !ref($names); |
65 | |
66 | for my $name (@$names) { |
67 | $CURRENT_METACLASS->add_attribute($name, @_); |
68 | } |
69 | } |
70 | |
209e00d2 |
71 | sub method { |
72 | confess "method must be called within the role { ... } block." |
73 | unless $CURRENT_METACLASS; |
74 | |
75 | my $caller = shift; |
76 | my $name = shift; |
77 | my $body = shift; |
78 | |
31c69f88 |
79 | my $method = $CURRENT_METACLASS->method_metaclass->wrap( |
209e00d2 |
80 | package_name => $caller, |
81 | name => $name, |
82 | body => $body, |
83 | ); |
84 | |
85 | $CURRENT_METACLASS->add_method($name => $method); |
86 | } |
87 | |
03c4551d |
88 | sub before { |
89 | confess "before must be called within the role { ... } block." |
90 | unless $CURRENT_METACLASS; |
91 | |
92 | my $code = pop @_; |
93 | |
94 | for (@_) { |
95 | croak "Roles do not currently support " |
96 | . ref($_) |
97 | . " references for before method modifiers" |
98 | if ref $_; |
99 | $CURRENT_METACLASS->add_before_method_modifier($_, $code); |
100 | } |
101 | } |
102 | |
103 | sub after { |
104 | confess "after must be called within the role { ... } block." |
105 | unless $CURRENT_METACLASS; |
106 | |
107 | my $code = pop @_; |
108 | |
109 | for (@_) { |
110 | croak "Roles do not currently support " |
111 | . ref($_) |
112 | . " references for after method modifiers" |
113 | if ref $_; |
114 | $CURRENT_METACLASS->add_after_method_modifier($_, $code); |
115 | } |
116 | } |
117 | |
118 | sub around { |
119 | confess "around must be called within the role { ... } block." |
120 | unless $CURRENT_METACLASS; |
121 | |
122 | my $code = pop @_; |
123 | |
124 | for (@_) { |
125 | croak "Roles do not currently support " |
126 | . ref($_) |
127 | . " references for around method modifiers" |
128 | if ref $_; |
129 | $CURRENT_METACLASS->add_around_method_modifier($_, $code); |
130 | } |
131 | } |
132 | |
d55c8861 |
133 | sub with { |
134 | confess "with must be called within the role { ... } block." |
135 | unless $CURRENT_METACLASS; |
136 | Moose::Util::apply_all_roles($CURRENT_METACLASS, @_); |
137 | } |
138 | |
eac6d242 |
139 | sub requires { |
140 | confess "requires must be called within the role { ... } block." |
141 | unless $CURRENT_METACLASS; |
142 | croak "Must specify at least one method" unless @_; |
143 | $CURRENT_METACLASS->add_required_methods(@_); |
144 | } |
145 | |
fa627596 |
146 | sub excludes { |
147 | confess "excludes must be called within the role { ... } block." |
148 | unless $CURRENT_METACLASS; |
149 | croak "Must specify at least one role" unless @_; |
150 | $CURRENT_METACLASS->add_excluded_roles(@_); |
151 | } |
152 | |
20725a2d |
153 | # see Moose.pm for discussion |
154 | sub super { |
155 | return unless $Moose::SUPER_BODY; |
156 | $Moose::SUPER_BODY->(@Moose::SUPER_ARGS); |
157 | } |
158 | |
159 | sub override { |
160 | confess "override must be called within the role { ... } block." |
161 | unless $CURRENT_METACLASS; |
162 | |
163 | my ($name, $code) = @_; |
164 | $CURRENT_METACLASS->add_override_method_modifier($name, $code); |
165 | } |
166 | |
fc4a95b6 |
167 | sub extends { croak "Roles do not currently support 'extends'" } |
168 | |
169 | sub inner { croak "Roles cannot support 'inner'" } |
170 | |
171 | sub augment { croak "Roles cannot support 'augment'" } |
172 | |
7b42fc96 |
173 | 1; |
174 | |