line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
24
|
|
|
24
|
|
1472399
|
use 5.014; |
|
24
|
|
|
|
|
253
|
|
2
|
24
|
|
|
20
|
|
131
|
use strict; |
|
20
|
|
|
|
|
46
|
|
|
20
|
|
|
|
|
434
|
|
3
|
20
|
|
|
19
|
|
94
|
use warnings; |
|
19
|
|
|
|
|
45
|
|
|
19
|
|
|
|
|
492
|
|
4
|
19
|
|
|
19
|
|
107
|
use B (); |
|
19
|
|
|
|
|
34
|
|
|
19
|
|
|
|
|
347
|
|
5
|
19
|
|
|
19
|
|
89
|
use Carp (); |
|
19
|
|
|
|
|
34
|
|
|
19
|
|
|
|
|
338
|
|
6
|
19
|
|
|
19
|
|
8335
|
use Import::Into (); |
|
19
|
|
|
|
|
47635
|
|
|
19
|
|
|
|
|
481
|
|
7
|
19
|
|
|
19
|
|
12815
|
use MooX::Press 0.025 (); |
|
19
|
|
|
|
|
2521461
|
|
|
19
|
|
|
|
|
719
|
|
8
|
19
|
|
|
19
|
|
7736
|
use MooX::Press::Keywords (); |
|
19
|
|
|
|
|
2018497
|
|
|
19
|
|
|
|
|
569
|
|
9
|
19
|
|
|
19
|
|
9616
|
use Syntax::Keyword::Try (); |
|
19
|
|
|
|
|
14292
|
|
|
19
|
|
|
|
|
487
|
|
10
|
19
|
|
|
19
|
|
138
|
use feature (); |
|
19
|
|
|
|
|
42
|
|
|
19
|
|
|
|
|
894
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
package MooX::Pression; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:TOBYINK'; |
15
|
|
|
|
|
|
|
our $VERSION = '0.300'; |
16
|
|
|
|
|
|
|
|
17
|
19
|
|
|
19
|
|
7622
|
use Keyword::Simple (); |
|
19
|
|
|
|
|
44213
|
|
|
19
|
|
|
|
|
481
|
|
18
|
19
|
|
|
19
|
|
13634
|
use PPR; |
|
19
|
|
|
|
|
741319
|
|
|
19
|
|
|
|
|
862
|
|
19
|
19
|
|
|
19
|
|
209
|
use B::Hooks::EndOfScope; |
|
19
|
|
|
|
|
44
|
|
|
19
|
|
|
|
|
282
|
|
20
|
19
|
|
|
19
|
|
11204
|
use Exporter::Shiny our @EXPORT = qw( version authority overload ); |
|
19
|
|
|
|
|
8432
|
|
|
19
|
|
|
|
|
159
|
|
21
|
19
|
|
|
19
|
|
8702
|
use Devel::StrictMode qw(STRICT); |
|
19
|
|
|
|
|
6637
|
|
|
19
|
|
|
|
|
17911
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
BEGIN { |
24
|
|
|
|
|
|
|
package MooX::Pression::_Gather; |
25
|
19
|
|
|
19
|
|
174
|
my %gather; |
26
|
|
|
|
|
|
|
my %stack; |
27
|
|
|
|
|
|
|
sub import { |
28
|
230
|
|
|
230
|
|
8810
|
my ($me, $action, $caller) = (shift, shift, scalar caller); |
29
|
230
|
100
|
|
|
|
1154
|
if ($action eq -gather) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
30
|
85
|
|
|
|
|
331
|
while (@_) { |
31
|
162
|
|
|
|
|
480
|
my ($k, $v) = splice @_, 0, 2; |
32
|
162
|
100
|
|
|
|
917
|
if (my ($kind,$pkg) = ($k =~ /^(class|role|class_generator|role_generator):(.+)$/)) { |
33
|
60
|
50
|
|
|
|
141
|
if ( my @stack = @{ $stack{$me}{$caller}||[] } ) { |
|
60
|
50
|
|
|
|
472
|
|
34
|
60
|
50
|
|
|
|
239
|
pop @stack if $stack[-1] eq $pkg; |
35
|
60
|
100
|
|
|
|
199
|
if (@stack) { |
36
|
25
|
|
|
|
|
62
|
$v->{_stack} = \@stack; |
37
|
25
|
|
|
|
|
64
|
$kind = '_defer_'.$kind; |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
} |
40
|
60
|
|
100
|
|
|
128
|
push @{ $gather{$me}{$caller}{$kind}||=[] }, $pkg, $v; |
|
60
|
|
|
|
|
2491
|
|
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
else { |
43
|
102
|
|
|
|
|
371
|
$gather{$me}{$caller}{$k} = $v; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
elsif ($action eq -go) { |
48
|
25
|
50
|
|
|
|
152
|
if ($gather{$me}{$caller}{'_defer_role'}) { |
49
|
0
|
|
|
|
|
0
|
require Carp; |
50
|
0
|
|
|
|
|
0
|
Carp::croak('Nested roles are not supported'); |
51
|
|
|
|
|
|
|
} |
52
|
25
|
50
|
|
|
|
124
|
if ($gather{$me}{$caller}{'_defer_role_generator'}) { |
53
|
0
|
|
|
|
|
0
|
require Carp; |
54
|
0
|
|
|
|
|
0
|
Carp::croak('Nested role generators are not supported'); |
55
|
|
|
|
|
|
|
} |
56
|
25
|
100
|
|
|
|
119
|
if ($gather{$me}{$caller}{'_defer_class_generator'}) { |
57
|
1
|
|
50
|
|
|
13
|
$me->_undefer_class_generators($gather{$me}{$caller}{'class_generator'}||=[], delete $gather{$me}{$caller}{'_defer_class_generator'}); |
58
|
|
|
|
|
|
|
} |
59
|
25
|
100
|
|
|
|
120
|
if ($gather{$me}{$caller}{'_defer_class'}) { |
60
|
5
|
|
|
|
|
37
|
$me->_undefer_classes($gather{$me}{$caller}{'class'}, delete $gather{$me}{$caller}{'_defer_class'}); |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
22
|
50
|
|
|
|
125
|
if ($gather{$me}{$caller}{debug}) { |
64
|
0
|
|
|
|
|
0
|
require Data::Dumper; |
65
|
0
|
|
|
|
|
0
|
warn Data::Dumper::Dumper($gather{$me}{$caller}); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
22
|
|
|
|
|
95
|
@_ = ('MooX::Press' => $gather{$me}{$caller}); |
69
|
22
|
|
|
|
|
210
|
goto \&MooX::Press::import; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
elsif ($action eq -parent) { |
72
|
60
|
|
100
|
|
|
123
|
push @{ $stack{$me}{$caller}||=[] }, $_[0]; |
|
60
|
|
|
|
|
3703
|
|
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
elsif ($action eq -unparent) { |
75
|
60
|
|
|
|
|
103
|
pop @{ $stack{$me}{$caller} }; |
|
60
|
|
|
|
|
1508
|
|
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
else { |
78
|
0
|
|
|
|
|
0
|
die; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
sub _undefer_classes { |
82
|
5
|
|
|
5
|
|
22
|
my ($me, $classes, $d) = @_; |
83
|
5
|
100
|
|
|
|
13
|
my %class_hash = @{$classes||[]}; |
|
5
|
|
|
|
|
43
|
|
84
|
5
|
|
|
|
|
14
|
my @deferred; |
85
|
5
|
|
|
|
|
13
|
my $max_depth = 0; |
86
|
5
|
|
|
|
|
22
|
while (@$d) { |
87
|
24
|
|
|
|
|
53
|
my ($class, $spec) = splice(@$d, 0, 2); |
88
|
24
|
|
|
|
|
54
|
$spec->{_class_name} = $class; |
89
|
24
|
|
|
|
|
31
|
$spec->{_depth} = @{ $spec->{_stack} }; |
|
24
|
|
|
|
|
49
|
|
90
|
24
|
|
|
|
|
41
|
push @deferred, $spec; |
91
|
24
|
100
|
|
|
|
71
|
$max_depth = $spec->{_depth} if $spec->{_depth} > $max_depth; |
92
|
|
|
|
|
|
|
} |
93
|
5
|
|
|
|
|
25
|
DEPTH: for my $depth (1 .. $max_depth) { |
94
|
8
|
|
|
|
|
20
|
SPEC: for my $spec (@deferred) { |
95
|
84
|
100
|
|
|
|
156
|
next SPEC unless $spec->{_depth} == $depth; |
96
|
24
|
|
|
|
|
32
|
my $parent_key = join('|', @{$spec->{_stack}}); |
|
24
|
|
|
|
|
58
|
|
97
|
24
|
|
|
|
|
36
|
my $my_key = join('|', @{$spec->{_stack}}, $spec->{_class_name}); |
|
24
|
|
|
|
|
51
|
|
98
|
24
|
100
|
|
|
|
52
|
if (not $class_hash{$parent_key}) { |
99
|
3
|
|
|
|
|
14
|
require Carp; |
100
|
|
|
|
|
|
|
Carp::croak(sprintf( |
101
|
|
|
|
|
|
|
'%s is nested in %s but %s is not a class', |
102
|
|
|
|
|
|
|
$spec->{_class_name}, |
103
|
|
|
|
|
|
|
$spec->{_stack}[-1], |
104
|
3
|
|
|
|
|
1415
|
$spec->{_stack}[-1], |
105
|
|
|
|
|
|
|
)); |
106
|
|
|
|
|
|
|
} |
107
|
21
|
|
100
|
|
|
30
|
push @{ $class_hash{$parent_key}{subclass} ||=[] }, $spec->{_class_name}, $spec; |
|
21
|
|
|
|
|
71
|
|
108
|
21
|
|
|
|
|
56
|
$class_hash{$my_key} = $spec; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
} |
111
|
2
|
|
|
|
|
6
|
for my $spec (@deferred) { |
112
|
21
|
|
|
|
|
33
|
delete $spec->{_stack}; |
113
|
21
|
|
|
|
|
29
|
delete $spec->{_class_name}; |
114
|
21
|
|
|
|
|
34
|
delete $spec->{_depth}; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
sub _undefer_class_generators { |
118
|
1
|
|
|
1
|
|
4
|
my ($me, $classes, $d) = @_; |
119
|
1
|
|
|
|
|
5
|
while (@$d) { |
120
|
1
|
|
|
|
|
6
|
my ($class, $spec) = splice(@$d, 0, 2); |
121
|
1
|
|
|
|
|
4
|
my $extends = $spec->{_stack}[-1]; |
122
|
1
|
|
|
|
|
4
|
my $next = delete($spec->{code}); |
123
|
|
|
|
|
|
|
$spec->{code} = sub { |
124
|
2
|
|
|
2
|
|
98966
|
my $got = $next->(@_); |
125
|
2
|
|
50
|
|
|
29
|
$got->{extends} ||= [$extends]; |
126
|
2
|
|
|
|
|
16
|
$got; |
127
|
1
|
|
|
|
|
7
|
}; |
128
|
1
|
|
|
|
|
4
|
delete $spec->{_stack}; |
129
|
1
|
|
|
|
|
6
|
push @$classes, $class, $spec; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
19
|
|
|
|
|
80629
|
$INC{'MooX/Pression/_Gather.pm'} = __FILE__; |
134
|
|
|
|
|
|
|
}; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# |
137
|
|
|
|
|
|
|
# GRAMMAR |
138
|
|
|
|
|
|
|
# |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
our $GRAMMAR = qr{ |
141
|
|
|
|
|
|
|
(?(DEFINE) |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
(?<PerlKeyword> |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
(?: include (?&MxpIncludeSyntax) )| |
146
|
|
|
|
|
|
|
(?: class (?&MxpClassSyntax) )| |
147
|
|
|
|
|
|
|
(?: abstract (?&MxpAbstractSyntax) )| |
148
|
|
|
|
|
|
|
(?: role (?&MxpRoleSyntax) )| |
149
|
|
|
|
|
|
|
(?: interface (?&MxpRoleSyntax) )| |
150
|
|
|
|
|
|
|
(?: toolkit (?&MxpToolkitSyntax) )| |
151
|
|
|
|
|
|
|
(?: begin (?&MxpHookSyntax) )| |
152
|
|
|
|
|
|
|
(?: end (?&MxpHookSyntax) )| |
153
|
|
|
|
|
|
|
(?: type_name (?&MxpTypeNameSyntax) )| |
154
|
|
|
|
|
|
|
(?: extends (?&MxpExtendsSyntax) )| |
155
|
|
|
|
|
|
|
(?: with (?&MxpWithSyntax) )| |
156
|
|
|
|
|
|
|
(?: requires (?&MxpWithSyntax) )| |
157
|
|
|
|
|
|
|
(?: has (?&MxpHasSyntax) )| |
158
|
|
|
|
|
|
|
(?: constant (?&MxpConstantSyntax) )| |
159
|
|
|
|
|
|
|
(?: coerce (?&MxpCoerceSyntax) )| |
160
|
|
|
|
|
|
|
(?: method (?&MxpMethodSyntax) )| |
161
|
|
|
|
|
|
|
(?: factory (?&MxpFactorySyntax) )| |
162
|
|
|
|
|
|
|
(?: factory (?&MxpFactoryViaSyntax))| |
163
|
|
|
|
|
|
|
(?: before (?&MxpModifierSyntax) )| |
164
|
|
|
|
|
|
|
(?: after (?&MxpModifierSyntax) )| |
165
|
|
|
|
|
|
|
(?: around (?&MxpModifierSyntax) )| |
166
|
|
|
|
|
|
|
(?: multi (?&MxpMultiSyntax) ) |
167
|
|
|
|
|
|
|
)#</PerlKeyword> |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
(?<MxpSimpleTypeSpec> |
170
|
|
|
|
|
|
|
~?(?&PerlBareword)(?&PerlAnonymousArray)? |
171
|
|
|
|
|
|
|
)#</MxpSimpleTypeSpec> |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
(?<MxpTypeSpec> |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
(?&MxpSimpleTypeSpec) |
176
|
|
|
|
|
|
|
(?: |
177
|
|
|
|
|
|
|
\s*\&\s* |
178
|
|
|
|
|
|
|
(?&MxpSimpleTypeSpec) |
179
|
|
|
|
|
|
|
)* |
180
|
|
|
|
|
|
|
(?: |
181
|
|
|
|
|
|
|
\s*\|\s* |
182
|
|
|
|
|
|
|
(?&MxpSimpleTypeSpec) |
183
|
|
|
|
|
|
|
(?: |
184
|
|
|
|
|
|
|
\s*\&\s* |
185
|
|
|
|
|
|
|
(?&MxpSimpleTypeSpec) |
186
|
|
|
|
|
|
|
)* |
187
|
|
|
|
|
|
|
)* |
188
|
|
|
|
|
|
|
)#</MxpTypeSpec> |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
(?<MxpExtendedTypeSpec> |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
(?&MxpTypeSpec)|(?&PerlBlock) |
193
|
|
|
|
|
|
|
)#</MxpExtendedTypeSpec> |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
(?<MxpSignatureElement> |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
(?&PerlOWS) |
198
|
|
|
|
|
|
|
(?: (?&MxpExtendedTypeSpec))? # CAPTURE:type |
199
|
|
|
|
|
|
|
(?&PerlOWS) |
200
|
|
|
|
|
|
|
(?: # CAPTURE:name |
201
|
|
|
|
|
|
|
(?&PerlVariable) | (\*(?&PerlIdentifier)) |
202
|
|
|
|
|
|
|
) |
203
|
|
|
|
|
|
|
(?: # CAPTURE:postamble |
204
|
|
|
|
|
|
|
\? | ((?&PerlOWS)=(?&PerlOWS)(?&PerlTerm)) |
205
|
|
|
|
|
|
|
)? |
206
|
|
|
|
|
|
|
)#</MxpSignatureElement> |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
(?<MxpSignatureList> |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
(?&MxpSignatureElement) |
211
|
|
|
|
|
|
|
(?: |
212
|
|
|
|
|
|
|
(?&PerlOWS) |
213
|
|
|
|
|
|
|
, |
214
|
|
|
|
|
|
|
(?&PerlOWS) |
215
|
|
|
|
|
|
|
(?&MxpSignatureElement) |
216
|
|
|
|
|
|
|
)* |
217
|
|
|
|
|
|
|
)#</MxpSignatureList> |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
(?<MxpAttribute> |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
: |
222
|
|
|
|
|
|
|
[^\W0-9]\w* |
223
|
|
|
|
|
|
|
(?: |
224
|
|
|
|
|
|
|
[(] |
225
|
|
|
|
|
|
|
[^\)]+ |
226
|
|
|
|
|
|
|
[)] |
227
|
|
|
|
|
|
|
)? |
228
|
|
|
|
|
|
|
)#</MxpAttribute> |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
(?<MxpRoleList> |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
(?&PerlOWS) |
233
|
|
|
|
|
|
|
(?: |
234
|
|
|
|
|
|
|
(?&PerlBlock) | (?&PerlQualifiedIdentifier) |
235
|
|
|
|
|
|
|
) |
236
|
|
|
|
|
|
|
(?: |
237
|
|
|
|
|
|
|
(?:\s*\?) | (?: (?&PerlOWS)(?&PerlList)) |
238
|
|
|
|
|
|
|
)? |
239
|
|
|
|
|
|
|
(?: |
240
|
|
|
|
|
|
|
(?&PerlOWS) |
241
|
|
|
|
|
|
|
, |
242
|
|
|
|
|
|
|
(?&PerlOWS) |
243
|
|
|
|
|
|
|
(?: |
244
|
|
|
|
|
|
|
(?&PerlBlock) | (?&PerlQualifiedIdentifier) |
245
|
|
|
|
|
|
|
) |
246
|
|
|
|
|
|
|
(?: |
247
|
|
|
|
|
|
|
(?:\s*\?) | (?: (?&PerlOWS)(?&PerlList)) |
248
|
|
|
|
|
|
|
)? |
249
|
|
|
|
|
|
|
)* |
250
|
|
|
|
|
|
|
)#</MxpRoleList> |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
(?<MxpClassSyntax> |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
(?&PerlOWS) |
255
|
|
|
|
|
|
|
(?: [+] )? # CAPTURE:plus |
256
|
|
|
|
|
|
|
(?: (?&PerlQualifiedIdentifier) )? # CAPTURE:name |
257
|
|
|
|
|
|
|
(?&PerlOWS) |
258
|
|
|
|
|
|
|
(?: |
259
|
|
|
|
|
|
|
[(] |
260
|
|
|
|
|
|
|
(?&PerlOWS) |
261
|
|
|
|
|
|
|
(?: # CAPTURE:sig |
262
|
|
|
|
|
|
|
(?&MxpSignatureList)? |
263
|
|
|
|
|
|
|
) |
264
|
|
|
|
|
|
|
(?&PerlOWS) |
265
|
|
|
|
|
|
|
[)] |
266
|
|
|
|
|
|
|
)? |
267
|
|
|
|
|
|
|
(?&PerlOWS) |
268
|
|
|
|
|
|
|
(?: (?&PerlBlock) )? # CAPTURE:block |
269
|
|
|
|
|
|
|
(?&PerlOWS) |
270
|
|
|
|
|
|
|
)#</MxpClassSyntax> |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
(?<MxpIncludeSyntax> |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
(?&PerlOWS) |
275
|
|
|
|
|
|
|
(?: (?&PerlQualifiedIdentifier) )? # CAPTURE:name |
276
|
|
|
|
|
|
|
(?&PerlOWS) |
277
|
|
|
|
|
|
|
)#</MxpIncludeSyntax> |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
(?<MxpAbstractSyntax> |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
(?&PerlOWS) |
282
|
|
|
|
|
|
|
class |
283
|
|
|
|
|
|
|
(?&PerlOWS) |
284
|
|
|
|
|
|
|
(?: [+] )? # CAPTURE:plus |
285
|
|
|
|
|
|
|
(?: (?&PerlQualifiedIdentifier) )? # CAPTURE:name |
286
|
|
|
|
|
|
|
(?&PerlOWS) |
287
|
|
|
|
|
|
|
(?: |
288
|
|
|
|
|
|
|
[(] |
289
|
|
|
|
|
|
|
(?&PerlOWS) |
290
|
|
|
|
|
|
|
(?: # CAPTURE:sig |
291
|
|
|
|
|
|
|
(?&MxpSignatureList)? |
292
|
|
|
|
|
|
|
) |
293
|
|
|
|
|
|
|
(?&PerlOWS) |
294
|
|
|
|
|
|
|
[)] |
295
|
|
|
|
|
|
|
)? |
296
|
|
|
|
|
|
|
(?&PerlOWS) |
297
|
|
|
|
|
|
|
(?: (?&PerlBlock) )? # CAPTURE:block |
298
|
|
|
|
|
|
|
(?&PerlOWS) |
299
|
|
|
|
|
|
|
)#</MxpAbstractSyntax> |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
(?<MxpRoleSyntax> |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
(?&PerlOWS) |
304
|
|
|
|
|
|
|
(?: (?&PerlQualifiedIdentifier) )? # CAPTURE:name |
305
|
|
|
|
|
|
|
(?&PerlOWS) |
306
|
|
|
|
|
|
|
(?: |
307
|
|
|
|
|
|
|
[(] |
308
|
|
|
|
|
|
|
(?&PerlOWS) |
309
|
|
|
|
|
|
|
(?: # CAPTURE:sig |
310
|
|
|
|
|
|
|
(?&MxpSignatureList)? |
311
|
|
|
|
|
|
|
) |
312
|
|
|
|
|
|
|
(?&PerlOWS) |
313
|
|
|
|
|
|
|
[)] |
314
|
|
|
|
|
|
|
)? |
315
|
|
|
|
|
|
|
(?&PerlOWS) |
316
|
|
|
|
|
|
|
(?: (?&PerlBlock) )? # CAPTURE:block |
317
|
|
|
|
|
|
|
(?&PerlOWS) |
318
|
|
|
|
|
|
|
)#</MxpRoleSyntax> |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
(?<MxpHookSyntax> |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
(?&PerlOWS) |
323
|
|
|
|
|
|
|
(?: (?&PerlBlock) ) # CAPTURE:hook |
324
|
|
|
|
|
|
|
(?&PerlOWS) |
325
|
|
|
|
|
|
|
)#</MxpHookSyntax> |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
(?<MxpTypeNameSyntax> |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
(?&PerlOWS) |
330
|
|
|
|
|
|
|
(?: (?&PerlIdentifier) ) # CAPTURE:name |
331
|
|
|
|
|
|
|
(?&PerlOWS) |
332
|
|
|
|
|
|
|
)#</MxpTypeNameSyntax> |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
(?<MxpToolkitSyntax> |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
(?&PerlOWS) |
337
|
|
|
|
|
|
|
(?: (?&PerlIdentifier) ) # CAPTURE:name |
338
|
|
|
|
|
|
|
(?&PerlOWS) |
339
|
|
|
|
|
|
|
(?: |
340
|
|
|
|
|
|
|
[(] |
341
|
|
|
|
|
|
|
(?&PerlOWS) |
342
|
|
|
|
|
|
|
(?: # CAPTURE:imports |
343
|
|
|
|
|
|
|
(?: (?&PerlQualifiedIdentifier)|(?&PerlComma)|(?&PerlOWS) )* |
344
|
|
|
|
|
|
|
) |
345
|
|
|
|
|
|
|
(?&PerlOWS) |
346
|
|
|
|
|
|
|
[)] |
347
|
|
|
|
|
|
|
)? |
348
|
|
|
|
|
|
|
(?&PerlOWS) |
349
|
|
|
|
|
|
|
)#</MxpToolkitSyntax> |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
(?<MxpExtendsSyntax> |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
(?&PerlOWS) |
354
|
|
|
|
|
|
|
(?: # CAPTURE:list |
355
|
|
|
|
|
|
|
(?&MxpRoleList) |
356
|
|
|
|
|
|
|
) |
357
|
|
|
|
|
|
|
(?&PerlOWS) |
358
|
|
|
|
|
|
|
)#</MxpExtendsSyntax> |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
(?<MxpWithSyntax> |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
(?&PerlOWS) |
363
|
|
|
|
|
|
|
(?: # CAPTURE:list |
364
|
|
|
|
|
|
|
(?&MxpRoleList) |
365
|
|
|
|
|
|
|
) |
366
|
|
|
|
|
|
|
(?&PerlOWS) |
367
|
|
|
|
|
|
|
)#</MxpWithSyntax> |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
(?<MxpRequiresSyntax> |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
(?&PerlOWS) |
372
|
|
|
|
|
|
|
(?: (?&PerlIdentifier)|(?&PerlBlock) ) # CAPTURE:name |
373
|
|
|
|
|
|
|
(?&PerlOWS) |
374
|
|
|
|
|
|
|
(?: |
375
|
|
|
|
|
|
|
[(] |
376
|
|
|
|
|
|
|
(?&PerlOWS) |
377
|
|
|
|
|
|
|
(?: # CAPTURE:sig |
378
|
|
|
|
|
|
|
(?&MxpSignatureList)? |
379
|
|
|
|
|
|
|
) |
380
|
|
|
|
|
|
|
(?&PerlOWS) |
381
|
|
|
|
|
|
|
[)] |
382
|
|
|
|
|
|
|
)? |
383
|
|
|
|
|
|
|
(?&PerlOWS) |
384
|
|
|
|
|
|
|
)#</MxpRequiresSyntax> |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
(?<MxpHasSyntax> |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
(?&PerlOWS) |
389
|
|
|
|
|
|
|
(?: \+ )? # CAPTURE:plus |
390
|
|
|
|
|
|
|
(?: \* )? # CAPTURE:asterisk |
391
|
|
|
|
|
|
|
(?: (?&PerlIdentifier)|(?&PerlBlock) ) # CAPTURE:name |
392
|
|
|
|
|
|
|
(?: \! )? # CAPTURE:postfix |
393
|
|
|
|
|
|
|
(?&PerlOWS) |
394
|
|
|
|
|
|
|
(?: |
395
|
|
|
|
|
|
|
[(] |
396
|
|
|
|
|
|
|
(?&PerlOWS) |
397
|
|
|
|
|
|
|
(?: (?&PerlList) ) # CAPTURE:spec |
398
|
|
|
|
|
|
|
(?&PerlOWS) |
399
|
|
|
|
|
|
|
[)] |
400
|
|
|
|
|
|
|
)? |
401
|
|
|
|
|
|
|
(?&PerlOWS) |
402
|
|
|
|
|
|
|
(?: |
403
|
|
|
|
|
|
|
[=] |
404
|
|
|
|
|
|
|
(?&PerlOWS) |
405
|
|
|
|
|
|
|
(?: (?&PerlAssignment) ) # CAPTURE:default |
406
|
|
|
|
|
|
|
)? |
407
|
|
|
|
|
|
|
(?&PerlOWS) |
408
|
|
|
|
|
|
|
)#</MxpHasSyntax> |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
(?<MxpConstantSyntax> |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
(?&PerlOWS) |
413
|
|
|
|
|
|
|
(?: (?&PerlIdentifier) ) # CAPTURE:name |
414
|
|
|
|
|
|
|
(?&PerlOWS) |
415
|
|
|
|
|
|
|
= |
416
|
|
|
|
|
|
|
(?&PerlOWS) |
417
|
|
|
|
|
|
|
(?: (?&PerlExpression) ) # CAPTURE:expr |
418
|
|
|
|
|
|
|
(?&PerlOWS) |
419
|
|
|
|
|
|
|
)#</MxpConstantSyntax> |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
(?<MxpMethodSyntax> |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
(?&PerlOWS) |
424
|
|
|
|
|
|
|
(?: (?&PerlIdentifier)|(?&PerlBlock) )? # CAPTURE:name |
425
|
|
|
|
|
|
|
(?&PerlOWS) |
426
|
|
|
|
|
|
|
(?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes |
427
|
|
|
|
|
|
|
(?&PerlOWS) |
428
|
|
|
|
|
|
|
(?: |
429
|
|
|
|
|
|
|
[(] |
430
|
|
|
|
|
|
|
(?&PerlOWS) |
431
|
|
|
|
|
|
|
(?: # CAPTURE:sig |
432
|
|
|
|
|
|
|
(?&MxpSignatureList)? |
433
|
|
|
|
|
|
|
) |
434
|
|
|
|
|
|
|
(?&PerlOWS) |
435
|
|
|
|
|
|
|
[)] |
436
|
|
|
|
|
|
|
)? |
437
|
|
|
|
|
|
|
(?&PerlOWS) |
438
|
|
|
|
|
|
|
(?: (?&PerlBlock) ) # CAPTURE:code |
439
|
|
|
|
|
|
|
(?&PerlOWS) |
440
|
|
|
|
|
|
|
)#</MxpMethodSyntax> |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
(?<MxpMultiSyntax> |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
(?&PerlOWS) |
445
|
|
|
|
|
|
|
method |
446
|
|
|
|
|
|
|
(?&PerlOWS) |
447
|
|
|
|
|
|
|
(?: (?&PerlIdentifier)|(?&PerlBlock) ) # CAPTURE:name |
448
|
|
|
|
|
|
|
(?&PerlOWS) |
449
|
|
|
|
|
|
|
(?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes |
450
|
|
|
|
|
|
|
(?&PerlOWS) |
451
|
|
|
|
|
|
|
(?: |
452
|
|
|
|
|
|
|
[(] |
453
|
|
|
|
|
|
|
(?&PerlOWS) |
454
|
|
|
|
|
|
|
(?: # CAPTURE:sig |
455
|
|
|
|
|
|
|
(?&MxpSignatureList)? |
456
|
|
|
|
|
|
|
) |
457
|
|
|
|
|
|
|
(?&PerlOWS) |
458
|
|
|
|
|
|
|
[)] |
459
|
|
|
|
|
|
|
)? |
460
|
|
|
|
|
|
|
(?&PerlOWS) |
461
|
|
|
|
|
|
|
(?: (?&PerlBlock) ) # CAPTURE:code |
462
|
|
|
|
|
|
|
(?&PerlOWS) |
463
|
|
|
|
|
|
|
)#</MxpMultiSyntax> |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
(?<MxpModifierSyntax> |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
(?&PerlOWS) |
468
|
|
|
|
|
|
|
(?: (?&PerlIdentifier)|(?&PerlBlock) ) # CAPTURE:name |
469
|
|
|
|
|
|
|
(?&PerlOWS) |
470
|
|
|
|
|
|
|
(?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes |
471
|
|
|
|
|
|
|
(?&PerlOWS) |
472
|
|
|
|
|
|
|
(?: |
473
|
|
|
|
|
|
|
[(] |
474
|
|
|
|
|
|
|
(?&PerlOWS) |
475
|
|
|
|
|
|
|
(?: # CAPTURE:sig |
476
|
|
|
|
|
|
|
(?&MxpSignatureList)? |
477
|
|
|
|
|
|
|
) |
478
|
|
|
|
|
|
|
(?&PerlOWS) |
479
|
|
|
|
|
|
|
[)] |
480
|
|
|
|
|
|
|
)? |
481
|
|
|
|
|
|
|
(?&PerlOWS) |
482
|
|
|
|
|
|
|
(?: (?&PerlBlock) ) # CAPTURE:code |
483
|
|
|
|
|
|
|
(?&PerlOWS) |
484
|
|
|
|
|
|
|
)#</MxpModifierSyntax> |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
# Easier to provide two separate patterns for `factory` |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
(?<MxpFactorySyntax> |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
(?&PerlOWS) |
491
|
|
|
|
|
|
|
(?: (?&PerlIdentifier)|(?&PerlBlock) ) # CAPTURE:name |
492
|
|
|
|
|
|
|
(?&PerlOWS) |
493
|
|
|
|
|
|
|
(?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes |
494
|
|
|
|
|
|
|
(?&PerlOWS) |
495
|
|
|
|
|
|
|
(?: |
496
|
|
|
|
|
|
|
[(] |
497
|
|
|
|
|
|
|
(?&PerlOWS) |
498
|
|
|
|
|
|
|
(?: # CAPTURE:sig |
499
|
|
|
|
|
|
|
(?&MxpSignatureList)? |
500
|
|
|
|
|
|
|
) |
501
|
|
|
|
|
|
|
(?&PerlOWS) |
502
|
|
|
|
|
|
|
[)] |
503
|
|
|
|
|
|
|
)? |
504
|
|
|
|
|
|
|
(?&PerlOWS) |
505
|
|
|
|
|
|
|
(?: (?&PerlBlock) ) # CAPTURE:code |
506
|
|
|
|
|
|
|
(?&PerlOWS) |
507
|
|
|
|
|
|
|
)#</MxpFactorySyntax> |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
(?<MxpFactoryViaSyntax> |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
(?&PerlOWS) |
512
|
|
|
|
|
|
|
(?: (?&PerlIdentifier)|(?&PerlBlock) ) # CAPTURE:name |
513
|
|
|
|
|
|
|
(?&PerlOWS) |
514
|
|
|
|
|
|
|
(?: |
515
|
|
|
|
|
|
|
(: via ) |
516
|
|
|
|
|
|
|
(?: # CAPTURE:via |
517
|
|
|
|
|
|
|
(?&PerlBlock)|(?&PerlIdentifier)|(?&PerlString) |
518
|
|
|
|
|
|
|
) |
519
|
|
|
|
|
|
|
)? |
520
|
|
|
|
|
|
|
(?&PerlOWS) |
521
|
|
|
|
|
|
|
)#</MxpFactoryViaSyntax> |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
(?<MxpCoerceSyntax> |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
(?&PerlOWS) |
526
|
|
|
|
|
|
|
(?: from )? |
527
|
|
|
|
|
|
|
(?&PerlOWS) |
528
|
|
|
|
|
|
|
(?: # CAPTURE:from |
529
|
|
|
|
|
|
|
(?&PerlBlock)|(?&PerlQualifiedIdentifier)|(?&PerlString) |
530
|
|
|
|
|
|
|
) |
531
|
|
|
|
|
|
|
(?&PerlOWS) |
532
|
|
|
|
|
|
|
(?: via ) |
533
|
|
|
|
|
|
|
(?&PerlOWS) |
534
|
|
|
|
|
|
|
(?: # CAPTURE:via |
535
|
|
|
|
|
|
|
(?&PerlBlock)|(?&PerlIdentifier)|(?&PerlString) |
536
|
|
|
|
|
|
|
) |
537
|
|
|
|
|
|
|
(?&PerlOWS) |
538
|
|
|
|
|
|
|
(?: (?&PerlBlock) ) # CAPTURE:code |
539
|
|
|
|
|
|
|
(?&PerlOWS) |
540
|
|
|
|
|
|
|
)#</MxpCoerceSyntax> |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
) |
544
|
|
|
|
|
|
|
$PPR::GRAMMAR |
545
|
|
|
|
|
|
|
}xso; |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
my %_fetch_re_cache; |
548
|
|
|
|
|
|
|
sub _fetch_re { |
549
|
141
|
|
|
141
|
|
652
|
my $key = "@_"; |
550
|
141
|
|
|
|
|
298
|
my $name = shift; |
551
|
141
|
|
|
|
|
489
|
my %opts = @_; |
552
|
|
|
|
|
|
|
|
553
|
141
|
|
100
|
|
|
581
|
$opts{anchor} ||= ''; |
554
|
|
|
|
|
|
|
|
555
|
141
|
|
66
|
|
|
13091
|
$_fetch_re_cache{$key} ||= do { |
556
|
69
|
50
|
|
|
|
71008
|
"$GRAMMAR" =~ m{<$name>(.+)</$name>}s or die "could not fetch re for $name"; |
557
|
69
|
|
|
|
|
982
|
(my $re = $1) =~ s/\)\#$//; |
558
|
69
|
|
|
|
|
900
|
my @lines = split /\n/, $re; |
559
|
69
|
|
|
|
|
295
|
for (@lines) { |
560
|
1144
|
100
|
|
|
|
3077
|
if (my ($named_capture) = /# CAPTURE:(\w+)/) { |
561
|
225
|
|
|
|
|
1274
|
s/\(\?\:/\(\?<$named_capture>/; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
} |
564
|
69
|
|
|
|
|
363
|
$re = join "\n", @lines; |
565
|
|
|
|
|
|
|
$opts{anchor} eq 'start' ? qr/ ^ $re $GRAMMAR /xs : |
566
|
|
|
|
|
|
|
$opts{anchor} eq 'end' ? qr/ $re $GRAMMAR $ /xs : |
567
|
69
|
50
|
|
|
|
2968969
|
$opts{anchor} eq 'both' ? qr/ ^ $re $GRAMMAR $ /xs : qr/ $re $GRAMMAR /xs |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
# |
572
|
|
|
|
|
|
|
# HELPERS |
573
|
|
|
|
|
|
|
# |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
sub _handle_signature_list { |
576
|
23
|
|
|
23
|
|
68
|
my $me = shift; |
577
|
23
|
|
|
|
|
57
|
my $sig = $_[0]; |
578
|
23
|
|
|
|
|
52
|
my $seen_named = 0; |
579
|
23
|
|
|
|
|
71
|
my $seen_pos = 0; |
580
|
23
|
|
|
|
|
47
|
my @parsed; |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
return ( |
583
|
23
|
100
|
|
|
|
96
|
0, |
584
|
|
|
|
|
|
|
'', |
585
|
|
|
|
|
|
|
'[]', |
586
|
|
|
|
|
|
|
'', |
587
|
|
|
|
|
|
|
) if !$sig; |
588
|
|
|
|
|
|
|
|
589
|
19
|
|
|
|
|
80
|
while ($sig) { |
590
|
28
|
|
|
|
|
145
|
$sig =~ s/^\s+//xs; |
591
|
28
|
50
|
|
|
|
101
|
last if !$sig; |
592
|
|
|
|
|
|
|
|
593
|
28
|
|
|
|
|
115
|
push @parsed, {}; |
594
|
|
|
|
|
|
|
|
595
|
28
|
100
|
|
|
|
804616
|
if ($sig =~ /^((?&PerlBlock)) $GRAMMAR/xso) { |
|
|
100
|
|
|
|
|
|
596
|
3
|
|
|
|
|
119
|
my $type = $1; |
597
|
3
|
|
|
|
|
40
|
$parsed[-1]{type} = $type; |
598
|
3
|
|
|
|
|
12
|
$parsed[-1]{type_is_block} = 1; |
599
|
3
|
|
|
|
|
36
|
$sig =~ s/^\Q$type//xs; |
600
|
3
|
|
|
|
|
42070
|
$sig =~ s/^((?&PerlOWS)) $GRAMMAR//xso; |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
elsif ($sig =~ /^((?&MxpTypeSpec)) $GRAMMAR/xso) { |
603
|
19
|
|
|
|
|
177
|
my $type = $1; |
604
|
19
|
|
|
|
|
114
|
$parsed[-1]{type} = $type; |
605
|
19
|
|
|
|
|
66
|
$parsed[-1]{type_is_block} = 0; |
606
|
19
|
|
|
|
|
393
|
$sig =~ s/^\Q$type//xs; |
607
|
19
|
|
|
|
|
331430
|
$sig =~ s/^((?&PerlOWS)) $GRAMMAR//xso; |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
else { |
610
|
6
|
|
|
|
|
53
|
$parsed[-1]{type} = 'Any'; |
611
|
6
|
|
|
|
|
19
|
$parsed[-1]{type_is_block} = 0; |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
|
614
|
28
|
100
|
|
|
|
840592
|
if ($sig =~ /^\*((?&PerlIdentifier)) $GRAMMAR/xso) { |
|
|
50
|
|
|
|
|
|
615
|
2
|
|
|
|
|
8
|
my $name = $1; |
616
|
2
|
|
|
|
|
8
|
$parsed[-1]{name} = $name; |
617
|
2
|
|
|
|
|
8
|
$parsed[-1]{named} = 1; |
618
|
2
|
|
|
|
|
6
|
$parsed[-1]{positional} = 0; |
619
|
2
|
|
|
|
|
6
|
++$seen_named; |
620
|
2
|
|
|
|
|
28
|
$sig =~ s/^\*\Q$name//xs; |
621
|
2
|
|
|
|
|
41617
|
$sig =~ s/^((?&PerlOWS)) $GRAMMAR//xso; |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
elsif ($sig =~ /^((?&PerlVariable)) $GRAMMAR/xso) { |
624
|
26
|
|
|
|
|
285
|
my $name = $1; |
625
|
26
|
|
|
|
|
131
|
$parsed[-1]{name} = $name; |
626
|
26
|
|
|
|
|
107
|
$parsed[-1]{named} = 0; |
627
|
26
|
|
|
|
|
81
|
$parsed[-1]{positional} = 1; |
628
|
26
|
|
|
|
|
64
|
++$seen_pos; |
629
|
26
|
|
|
|
|
584
|
$sig =~ s/^\Q$name//xs; |
630
|
26
|
|
|
|
|
1076953
|
$sig =~ s/^((?&PerlOWS)) $GRAMMAR//xs; |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
|
633
|
28
|
50
|
|
|
|
478348
|
if ($sig =~ /^\?/) { |
|
|
100
|
|
|
|
|
|
634
|
0
|
|
|
|
|
0
|
$parsed[-1]{optional} = 1; |
635
|
0
|
|
|
|
|
0
|
$sig =~ s/^\?((?&PerlOWS)) $GRAMMAR//xso; |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
elsif ($sig =~ /^=((?&PerlOWS))((?&PerlTerm)) $GRAMMAR/xso) { |
638
|
2
|
|
|
|
|
22
|
my ($ws, $default) = ($1, $2); |
639
|
2
|
|
|
|
|
12
|
$parsed[-1]{default} = $default; |
640
|
2
|
|
|
|
|
34
|
$sig =~ s/^=\Q$ws$default//xs; |
641
|
2
|
|
|
|
|
82250
|
$sig =~ s/^((?&PerlOWS)) $GRAMMAR//xso; |
642
|
|
|
|
|
|
|
} |
643
|
|
|
|
|
|
|
|
644
|
28
|
100
|
|
|
|
3067
|
if ($sig) { |
645
|
9
|
50
|
|
|
|
101
|
$sig =~ /^,/ or die "WEIRD SIGNATURE??? $sig"; |
646
|
9
|
|
|
|
|
199
|
$sig =~ s/^,//; |
647
|
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
} |
649
|
|
|
|
|
|
|
|
650
|
19
|
|
|
|
|
78
|
my @signature_var_list; |
651
|
19
|
|
|
|
|
78
|
my $type_params_stuff = '['; |
652
|
|
|
|
|
|
|
|
653
|
19
|
|
|
|
|
72
|
my (@head, @tail); |
654
|
19
|
50
|
66
|
|
|
220
|
if ($seen_named and $seen_pos) { |
655
|
0
|
|
0
|
|
|
0
|
while (@parsed and $parsed[0]{positional}) { |
656
|
0
|
|
|
|
|
0
|
push @head, shift @parsed; |
657
|
|
|
|
|
|
|
} |
658
|
0
|
|
0
|
|
|
0
|
while (@parsed and $parsed[-1]{positional}) { |
659
|
0
|
|
|
|
|
0
|
unshift @tail, pop @parsed; |
660
|
|
|
|
|
|
|
} |
661
|
0
|
0
|
|
|
|
0
|
if (grep $_->{positional}, @parsed) { |
662
|
0
|
|
|
|
|
0
|
require Carp; |
663
|
0
|
|
|
|
|
0
|
Carp::croak("Signature contains an unexpected mixture of positional and named parameters"); |
664
|
|
|
|
|
|
|
} |
665
|
0
|
|
|
|
|
0
|
for my $p (@head, @tail) { |
666
|
0
|
|
|
|
|
0
|
my $is_optional = $p->{optional}; |
667
|
0
|
|
0
|
|
|
0
|
$is_optional ||= ($p->{type} =~ /^Optional/s); |
668
|
0
|
0
|
|
|
|
0
|
if ($is_optional) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
669
|
0
|
|
|
|
|
0
|
require Carp; |
670
|
0
|
|
|
|
|
0
|
Carp::croak("Cannot have optional positional parameter $p->{name} in signature with named parameters"); |
671
|
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
elsif ($p->{default}) { |
673
|
0
|
|
|
|
|
0
|
require Carp; |
674
|
0
|
|
|
|
|
0
|
Carp::croak("Cannot have positional parameter $p->{name} with default in signature with named parameters"); |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
elsif ($p->{name} =~ /^[\@\%]/) { |
677
|
0
|
|
|
|
|
0
|
require Carp; |
678
|
0
|
|
|
|
|
0
|
Carp::croak("Cannot have slurpy parameter $p->{name} in signature with named parameters"); |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
|
683
|
19
|
|
|
|
|
322
|
require B; |
684
|
|
|
|
|
|
|
|
685
|
19
|
|
|
|
|
62
|
my $extra = ''; |
686
|
19
|
|
|
|
|
66
|
my $count = @parsed; |
687
|
19
|
|
|
|
|
204
|
while (my $p = shift @parsed) { |
688
|
28
|
100
|
|
|
|
104
|
$type_params_stuff .= B::perlstring($p->{name}) . ',' if $seen_named; |
689
|
28
|
100
|
|
|
|
251
|
if ($p->{name} =~ /^[\@\%]/) { |
690
|
3
|
50
|
|
|
|
13
|
die "Cannot have slurpy in non-final position" if @parsed; |
691
|
|
|
|
|
|
|
$extra .= sprintf( |
692
|
|
|
|
|
|
|
'my (%s) = (@_==%d ? %s{$_[-1]} : ());', |
693
|
|
|
|
|
|
|
$p->{name}, |
694
|
|
|
|
|
|
|
$count, |
695
|
3
|
|
|
|
|
52
|
substr($p->{name}, 0, 1), |
696
|
|
|
|
|
|
|
); |
697
|
3
|
|
|
|
|
15
|
$p->{slurpy} = 1; |
698
|
3
|
100
|
|
|
|
48
|
if ($p->{type} eq 'Any') { |
699
|
2
|
100
|
|
|
|
10
|
$p->{type} = substr($p->{name}, 0, 1) eq '%' ? 'HashRef' : 'ArrayRef'; |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
} |
702
|
|
|
|
|
|
|
else { |
703
|
25
|
|
|
|
|
107
|
push @signature_var_list, $p->{name}; |
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
|
706
|
28
|
100
|
|
|
|
101
|
if ($p->{type_is_block}) { |
707
|
3
|
|
|
|
|
43
|
$type_params_stuff .= sprintf('scalar(do %s)', $p->{type}) . ','; |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
else { |
710
|
25
|
|
|
|
|
228
|
$type_params_stuff .= B::perlstring($p->{type}) . ','; |
711
|
|
|
|
|
|
|
} |
712
|
28
|
100
|
66
|
|
|
411
|
if (exists $p->{optional} or exists $p->{default} or $p->{slurpy}) { |
|
|
|
100
|
|
|
|
|
713
|
5
|
|
|
|
|
17
|
$type_params_stuff .= '{'; |
714
|
5
|
50
|
|
|
|
20
|
$type_params_stuff .= sprintf('optional=>%d,', !!$p->{optional}) if exists $p->{optional}; |
715
|
5
|
100
|
|
|
|
106
|
$type_params_stuff .= sprintf('default=>sub{scalar(%s)},', $p->{default}) if exists $p->{default}; |
716
|
5
|
100
|
|
|
|
28
|
$type_params_stuff .= sprintf('slurpy=>%d,', !!$p->{slurpy}) if exists $p->{slurpy}; |
717
|
5
|
|
|
|
|
29
|
$type_params_stuff .= '},'; |
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
|
|
721
|
19
|
100
|
|
|
|
92
|
@signature_var_list = '$arg' if $seen_named; |
722
|
19
|
|
|
|
|
60
|
$type_params_stuff .= ']'; |
723
|
|
|
|
|
|
|
|
724
|
19
|
50
|
33
|
|
|
127
|
if (@head or @tail) { |
725
|
0
|
|
|
|
|
0
|
require Type::Params; |
726
|
0
|
|
|
|
|
0
|
'Type::Params'->VERSION(1.009002); |
727
|
0
|
0
|
|
|
|
0
|
my $head_stuff = join(q[,] => map { $_->{type_is_block} ? sprintf('scalar(do %s)', $_->{type}) : B::perlstring($_->{type}) } @head); |
|
0
|
|
|
|
|
0
|
|
728
|
0
|
0
|
|
|
|
0
|
my $tail_stuff = join(q[,] => map { $_->{type_is_block} ? sprintf('scalar(do %s)', $_->{type}) : B::perlstring($_->{type}) } @tail); |
|
0
|
|
|
|
|
0
|
|
729
|
0
|
0
|
|
|
|
0
|
my $opts = sprintf('{head=>%s,tail=>%s},', $head_stuff?"[$head_stuff]":0, $tail_stuff?"[$tail_stuff]":0); |
|
|
0
|
|
|
|
|
|
730
|
0
|
|
|
|
|
0
|
substr($type_params_stuff, 1, 0) = $opts; # insert options after "[" |
731
|
0
|
|
|
|
|
0
|
unshift @signature_var_list, map $_->{name}, @head; |
732
|
0
|
|
|
|
|
0
|
push @signature_var_list, map $_->{name}, @tail; |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
return ( |
736
|
19
|
|
|
|
|
316
|
$seen_named, |
737
|
|
|
|
|
|
|
join(',', @signature_var_list), |
738
|
|
|
|
|
|
|
$type_params_stuff, |
739
|
|
|
|
|
|
|
$extra, |
740
|
|
|
|
|
|
|
); |
741
|
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
sub _handle_role_list { |
744
|
14
|
|
|
14
|
|
52
|
my $me = shift; |
745
|
14
|
|
|
|
|
76
|
my ($rolelist, $kind) = @_; |
746
|
14
|
|
|
|
|
36
|
my @return; |
747
|
|
|
|
|
|
|
|
748
|
14
|
|
|
|
|
72
|
while (length $rolelist) { |
749
|
15
|
|
|
|
|
81
|
$rolelist =~ s/^\s+//xs; |
750
|
|
|
|
|
|
|
|
751
|
15
|
|
|
|
|
45
|
my $prefix = ''; |
752
|
15
|
|
|
|
|
32
|
my $role = undef; |
753
|
15
|
|
|
|
|
33
|
my $role_is_block = 0; |
754
|
15
|
|
|
|
|
37
|
my $suffix = ''; |
755
|
15
|
|
|
|
|
31
|
my $role_params = undef; |
756
|
|
|
|
|
|
|
|
757
|
15
|
100
|
|
|
|
671702
|
if ($rolelist =~ /^((?&PerlBlock)) $GRAMMAR/xso) { |
|
|
50
|
|
|
|
|
|
758
|
3
|
|
|
|
|
109
|
$role = $1; |
759
|
3
|
|
|
|
|
8
|
$role_is_block = 1; |
760
|
3
|
|
|
|
|
98
|
$rolelist =~ s/^\Q$role//xs; |
761
|
3
|
|
|
|
|
11
|
$rolelist =~ s/^\s+//xs; |
762
|
|
|
|
|
|
|
} |
763
|
|
|
|
|
|
|
elsif ($rolelist =~ /^((?&PerlQualifiedIdentifier)) $GRAMMAR/xso) { |
764
|
12
|
|
|
|
|
143
|
$role = $1; |
765
|
12
|
|
|
|
|
330
|
$rolelist =~ s/^\Q$role//xs; |
766
|
12
|
|
|
|
|
99
|
$rolelist =~ s/^\s+//xs; |
767
|
|
|
|
|
|
|
} |
768
|
|
|
|
|
|
|
else { |
769
|
0
|
|
|
|
|
0
|
die "expected role name, got $rolelist"; |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
|
772
|
15
|
100
|
|
|
|
387139
|
if ($rolelist =~ /^\?/xs) { |
|
|
100
|
|
|
|
|
|
773
|
4
|
50
|
|
|
|
19
|
die 'unexpected question mark' if $kind eq 'class'; |
774
|
4
|
|
|
|
|
9
|
$suffix = '?'; |
775
|
4
|
|
|
|
|
16
|
$rolelist =~ s/^\?\s*//xs; |
776
|
|
|
|
|
|
|
} |
777
|
|
|
|
|
|
|
elsif ($rolelist =~ /^((?&PerlList)) $GRAMMAR/xso) { |
778
|
4
|
|
|
|
|
53
|
$role_params = $1; |
779
|
4
|
|
|
|
|
112
|
$rolelist =~ s/^\Q$role_params//xs; |
780
|
4
|
|
|
|
|
22
|
$rolelist =~ s/^\s+//xs; |
781
|
|
|
|
|
|
|
} |
782
|
|
|
|
|
|
|
|
783
|
15
|
100
|
|
|
|
1799
|
if ($role_is_block) { |
784
|
3
|
|
|
|
|
38
|
push @return, sprintf('sprintf(q(%s%%s%s), scalar(do %s))', $prefix, $suffix, $role); |
785
|
|
|
|
|
|
|
} |
786
|
|
|
|
|
|
|
else { |
787
|
12
|
|
|
|
|
246
|
push @return, B::perlstring("$prefix$role$suffix"); |
788
|
|
|
|
|
|
|
} |
789
|
15
|
100
|
|
|
|
66
|
if ($role_params) { |
790
|
4
|
|
|
|
|
38
|
push @return, sprintf('[%s]', $role_params); |
791
|
|
|
|
|
|
|
} |
792
|
|
|
|
|
|
|
|
793
|
15
|
|
|
|
|
49
|
$rolelist =~ s/^\s+//xs; |
794
|
15
|
100
|
|
|
|
190
|
if (length $rolelist) { |
795
|
1
|
50
|
|
|
|
7
|
$rolelist =~ /^,/ or die "expected comma, got $rolelist"; |
796
|
1
|
|
|
|
|
16
|
$rolelist =~ s/^\,\s*//; |
797
|
|
|
|
|
|
|
} |
798
|
|
|
|
|
|
|
} |
799
|
|
|
|
|
|
|
|
800
|
14
|
|
|
|
|
1745
|
return join(",", @return); |
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
sub _handle_factory_keyword { |
804
|
2
|
|
|
2
|
|
10
|
my ($me, $name, $via, $code, $has_sig, $sig, $attrs) = @_; |
805
|
|
|
|
|
|
|
|
806
|
2
|
|
|
|
|
4
|
my $optim; |
807
|
2
|
|
|
|
|
9
|
for my $attr (@$attrs) { |
808
|
0
|
0
|
|
|
|
0
|
$optim = 1 if $attr =~ /^:optimize\b/; |
809
|
|
|
|
|
|
|
} |
810
|
|
|
|
|
|
|
|
811
|
2
|
50
|
|
|
|
8
|
if ($via) { |
812
|
0
|
0
|
|
|
|
0
|
return sprintf( |
|
|
0
|
|
|
|
|
|
813
|
|
|
|
|
|
|
'q[%s]->_factory(%s, \\(%s));', |
814
|
|
|
|
|
|
|
$me, |
815
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
816
|
|
|
|
|
|
|
($via =~ /^\{/ ? "scalar(do $via)" : B::perlstring($via)), |
817
|
|
|
|
|
|
|
); |
818
|
|
|
|
|
|
|
} |
819
|
2
|
50
|
|
|
|
11
|
if (!$has_sig) { |
820
|
0
|
|
|
|
|
0
|
my $munged_code = sprintf('sub { my ($factory, $class) = (@_); do %s }', $code); |
821
|
0
|
0
|
|
|
|
0
|
return sprintf( |
|
|
0
|
|
|
|
|
|
822
|
|
|
|
|
|
|
'q[%s]->_factory(%s, { caller => __PACKAGE__, code => %s, optimize => %d });', |
823
|
|
|
|
|
|
|
$me, |
824
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
825
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
826
|
|
|
|
|
|
|
!!$optim, |
827
|
|
|
|
|
|
|
); |
828
|
|
|
|
|
|
|
} |
829
|
2
|
|
|
|
|
10
|
my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig); |
830
|
2
|
|
|
|
|
21
|
my $munged_code = sprintf('sub { my($factory,$class,%s)=(shift,shift,@_); %s; do %s }', $signature_var_list, $extra, $code); |
831
|
2
|
50
|
|
|
|
44
|
sprintf( |
|
|
50
|
|
|
|
|
|
832
|
|
|
|
|
|
|
'q[%s]->_factory(%s, { caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });', |
833
|
|
|
|
|
|
|
$me, |
834
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
835
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
836
|
|
|
|
|
|
|
!!$signature_is_named, |
837
|
|
|
|
|
|
|
$type_params_stuff, |
838
|
|
|
|
|
|
|
!!$optim, |
839
|
|
|
|
|
|
|
); |
840
|
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
sub _handle_method_keyword { |
843
|
11
|
|
|
11
|
|
36
|
my $me = shift; |
844
|
11
|
|
|
|
|
44
|
my ($name, $code, $has_sig, $sig, $attrs) = @_; |
845
|
|
|
|
|
|
|
|
846
|
11
|
|
|
|
|
25
|
my $optim; |
847
|
11
|
|
|
|
|
56
|
for my $attr (@$attrs) { |
848
|
1
|
50
|
|
|
|
10
|
$optim = 1 if $attr =~ /^:optimize\b/; |
849
|
|
|
|
|
|
|
} |
850
|
|
|
|
|
|
|
|
851
|
11
|
100
|
|
|
|
46
|
if (defined $name) { |
852
|
10
|
100
|
|
|
|
37
|
if ($has_sig) { |
853
|
9
|
|
|
|
|
56
|
my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig); |
854
|
9
|
|
|
|
|
71
|
my $munged_code = sprintf('sub { my($self,%s)=(shift,@_); %s; my $class = ref($self)||$self; do %s }', $signature_var_list, $extra, $code); |
855
|
9
|
50
|
|
|
|
2387
|
return sprintf( |
|
|
100
|
|
|
|
|
|
856
|
|
|
|
|
|
|
'q[%s]->_can(%s, { caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });', |
857
|
|
|
|
|
|
|
$me, |
858
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
859
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
860
|
|
|
|
|
|
|
!!$signature_is_named, |
861
|
|
|
|
|
|
|
$type_params_stuff, |
862
|
|
|
|
|
|
|
!!$optim, |
863
|
|
|
|
|
|
|
); |
864
|
|
|
|
|
|
|
} |
865
|
|
|
|
|
|
|
else { |
866
|
1
|
|
|
|
|
10
|
my $munged_code = sprintf('sub { my $self = $_[0]; my $class = ref($self)||$self; do %s }', $code); |
867
|
1
|
50
|
|
|
|
246
|
return sprintf( |
|
|
50
|
|
|
|
|
|
868
|
|
|
|
|
|
|
'q[%s]->_can(%s, { caller => __PACKAGE__, code => %s, optimize => %d });', |
869
|
|
|
|
|
|
|
$me, |
870
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
871
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
872
|
|
|
|
|
|
|
!!$optim, |
873
|
|
|
|
|
|
|
); |
874
|
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
|
} |
876
|
|
|
|
|
|
|
else { |
877
|
1
|
50
|
|
|
|
5
|
if ($has_sig) { |
878
|
1
|
|
|
|
|
5
|
my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig); |
879
|
1
|
|
|
|
|
83
|
my $munged_code = sprintf('sub { my($self,%s)=(shift,@_); %s; my $class = ref($self)||$self; do %s }', $signature_var_list, $extra, $code); |
880
|
1
|
50
|
|
|
|
291
|
return sprintf( |
881
|
|
|
|
|
|
|
'q[%s]->wrap_coderef({ caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });', |
882
|
|
|
|
|
|
|
'MooX::Press', |
883
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
884
|
|
|
|
|
|
|
!!$signature_is_named, |
885
|
|
|
|
|
|
|
$type_params_stuff, |
886
|
|
|
|
|
|
|
!!$optim, |
887
|
|
|
|
|
|
|
); |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
else { |
890
|
0
|
|
|
|
|
0
|
my $munged_code = sprintf('sub { my $self = $_[0]; my $class = ref($self)||$self; do %s }', $code); |
891
|
0
|
0
|
|
|
|
0
|
return sprintf( |
892
|
|
|
|
|
|
|
'q[%s]->wrap_coderef({ caller => __PACKAGE__, code => %s, optimize => %d });', |
893
|
|
|
|
|
|
|
'MooX::Press', |
894
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
895
|
|
|
|
|
|
|
!!$optim, |
896
|
|
|
|
|
|
|
); |
897
|
|
|
|
|
|
|
} |
898
|
|
|
|
|
|
|
} |
899
|
|
|
|
|
|
|
} |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
sub _handle_multimethod_keyword { |
902
|
0
|
|
|
0
|
|
0
|
my $me = shift; |
903
|
0
|
|
|
|
|
0
|
my ($name, $code, $has_sig, $sig, $attrs) = @_; |
904
|
|
|
|
|
|
|
|
905
|
0
|
|
|
|
|
0
|
my $optim; |
906
|
0
|
|
|
|
|
0
|
my $extra_code = ''; |
907
|
0
|
|
|
|
|
0
|
for my $attr (@$attrs) { |
908
|
0
|
0
|
|
|
|
0
|
$optim = 1 if $attr =~ /^:optimize\b/; |
909
|
0
|
0
|
|
|
|
0
|
$extra_code .= sprintf('alias=>%s', B::perlstring($1)) if $attr =~ /^:alias\((.+)\)$/; |
910
|
|
|
|
|
|
|
} |
911
|
|
|
|
|
|
|
|
912
|
0
|
0
|
|
|
|
0
|
if ($has_sig) { |
913
|
0
|
|
|
|
|
0
|
my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig); |
914
|
0
|
|
|
|
|
0
|
my $munged_code = sprintf('sub { my($self,%s)=(shift,@_); %s; my $class = ref($self)||$self; do %s }', $signature_var_list, $extra, $code); |
915
|
0
|
0
|
|
|
|
0
|
return sprintf( |
916
|
|
|
|
|
|
|
'q[%s]->_multimethod(%s, { caller => __PACKAGE__, code => %s, named => %d, signature => %s, %s });', |
917
|
|
|
|
|
|
|
$me, |
918
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
919
|
|
|
|
|
|
|
$munged_code, |
920
|
|
|
|
|
|
|
!!$signature_is_named, |
921
|
|
|
|
|
|
|
$type_params_stuff, |
922
|
|
|
|
|
|
|
$extra_code, |
923
|
|
|
|
|
|
|
); |
924
|
|
|
|
|
|
|
} |
925
|
|
|
|
|
|
|
else { |
926
|
0
|
|
|
|
|
0
|
my $munged_code = sprintf('sub { my $self = $_[0]; my $class = ref($self)||$self; do %s }', $code); |
927
|
0
|
0
|
|
|
|
0
|
return sprintf( |
928
|
|
|
|
|
|
|
'q[%s]->_multimethod(%s, { caller => __PACKAGE__, code => %s, named => 0, signature => sub { @_ }, %s });', |
929
|
|
|
|
|
|
|
$me, |
930
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
931
|
|
|
|
|
|
|
$munged_code, |
932
|
|
|
|
|
|
|
$extra_code, |
933
|
|
|
|
|
|
|
); |
934
|
|
|
|
|
|
|
} |
935
|
|
|
|
|
|
|
} |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
sub _handle_modifier_keyword { |
938
|
1
|
|
|
1
|
|
7
|
my ($me, $kind, $name, $code, $has_sig, $sig, $attrs) = @_; |
939
|
|
|
|
|
|
|
|
940
|
1
|
|
|
|
|
4
|
my $optim; |
941
|
1
|
|
|
|
|
4
|
for my $attr (@$attrs) { |
942
|
0
|
0
|
|
|
|
0
|
$optim = 1 if $attr =~ /^:optimize\b/; |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
1
|
50
|
|
|
|
4
|
if ($has_sig) { |
|
|
0
|
|
|
|
|
|
946
|
1
|
|
|
|
|
7
|
my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig); |
947
|
1
|
|
|
|
|
3
|
my $munged_code; |
948
|
1
|
50
|
|
|
|
5
|
if ($kind eq 'around') { |
949
|
0
|
|
|
|
|
0
|
$munged_code = sprintf('sub { my($next,$self,%s)=(shift,shift,@_); %s; my $class = ref($self)||$self; do %s }', $signature_var_list, $extra, $code); |
950
|
|
|
|
|
|
|
} |
951
|
|
|
|
|
|
|
else { |
952
|
1
|
|
|
|
|
9
|
$munged_code = sprintf('sub { my($self,%s)=(shift,@_); %s; my $class = ref($self)||$self; do %s }', $signature_var_list, $extra, $code); |
953
|
|
|
|
|
|
|
} |
954
|
1
|
50
|
|
|
|
204
|
sprintf( |
|
|
50
|
|
|
|
|
|
955
|
|
|
|
|
|
|
'q[%s]->_modifier(q(%s), %s, { caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });', |
956
|
|
|
|
|
|
|
$me, |
957
|
|
|
|
|
|
|
$kind, |
958
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
959
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
960
|
|
|
|
|
|
|
!!$signature_is_named, |
961
|
|
|
|
|
|
|
$type_params_stuff, |
962
|
|
|
|
|
|
|
!!$optim, |
963
|
|
|
|
|
|
|
); |
964
|
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
|
elsif ($kind eq 'around') { |
966
|
0
|
|
|
|
|
0
|
my $munged_code = sprintf('sub { my ($next, $self) = @_; my $class = ref($self)||$self; do %s }', $code); |
967
|
0
|
0
|
|
|
|
0
|
sprintf( |
|
|
0
|
|
|
|
|
|
968
|
|
|
|
|
|
|
'q[%s]->_modifier(q(%s), %s, { caller => __PACKAGE__, code => %s, optimize => %d });', |
969
|
|
|
|
|
|
|
$me, |
970
|
|
|
|
|
|
|
$kind, |
971
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
972
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
973
|
|
|
|
|
|
|
!!$optim, |
974
|
|
|
|
|
|
|
); |
975
|
|
|
|
|
|
|
} |
976
|
|
|
|
|
|
|
else { |
977
|
0
|
|
|
|
|
0
|
my $munged_code = sprintf('sub { my $self = $_[0]; my $class = ref($self)||$self; do %s }', $code); |
978
|
0
|
0
|
|
|
|
0
|
sprintf( |
|
|
0
|
|
|
|
|
|
979
|
|
|
|
|
|
|
'q[%s]->_modifier(q(%s), %s, { caller => __PACKAGE__, code => %s, optimize => %d });', |
980
|
|
|
|
|
|
|
$me, |
981
|
|
|
|
|
|
|
$kind, |
982
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
983
|
|
|
|
|
|
|
$optim ? B::perlstring($munged_code) : $munged_code, |
984
|
|
|
|
|
|
|
!!$optim, |
985
|
|
|
|
|
|
|
); |
986
|
|
|
|
|
|
|
} |
987
|
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
sub _handle_package_keyword { |
990
|
65
|
|
|
65
|
|
271
|
my ($me, $kind, $name, $code, $has_sig, $sig, $plus, $opts) = @_; |
991
|
|
|
|
|
|
|
|
992
|
65
|
100
|
|
|
|
238
|
if ($kind eq 'abstract') { |
993
|
1
|
|
|
|
|
3
|
$kind = 'class'; |
994
|
1
|
|
|
|
|
6
|
$code = "{ q[$me]->_abstract(1); $code }"; |
995
|
|
|
|
|
|
|
} |
996
|
|
|
|
|
|
|
|
997
|
65
|
50
|
|
|
|
213
|
if ($kind eq 'interface') { |
998
|
0
|
|
|
|
|
0
|
$kind = 'role'; |
999
|
0
|
|
|
|
|
0
|
$code = "{ q[$me]->_interface(1); $code }"; |
1000
|
|
|
|
|
|
|
} |
1001
|
|
|
|
|
|
|
|
1002
|
65
|
100
|
100
|
|
|
451
|
if ($name and $has_sig) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1003
|
7
|
|
|
|
|
43
|
my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig); |
1004
|
7
|
|
|
|
|
72
|
my $munged_code = sprintf('sub { q(%s)->_package_callback(sub { my ($generator,%s)=(shift,@_); %s; do %s }, @_) }', $me, $signature_var_list, $extra, $code); |
1005
|
7
|
|
|
|
|
1035
|
sprintf( |
1006
|
|
|
|
|
|
|
'use MooX::Pression::_Gather -parent => %s; use MooX::Pression::_Gather -gather, %s => { code => %s, named => %d, signature => %s }; use MooX::Pression::_Gather -unparent;', |
1007
|
|
|
|
|
|
|
B::perlstring("$plus$name"), |
1008
|
|
|
|
|
|
|
B::perlstring("$kind\_generator:$plus$name"), |
1009
|
|
|
|
|
|
|
$munged_code, |
1010
|
|
|
|
|
|
|
!!$signature_is_named, |
1011
|
|
|
|
|
|
|
$type_params_stuff, |
1012
|
|
|
|
|
|
|
); |
1013
|
|
|
|
|
|
|
} |
1014
|
|
|
|
|
|
|
elsif ($has_sig) { |
1015
|
1
|
|
|
|
|
6
|
my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig); |
1016
|
1
|
|
|
|
|
13
|
my $munged_code = sprintf('sub { q(%s)->_package_callback(sub { my ($generator,%s)=(shift,@_); %s; do %s }, @_) }', $me, $signature_var_list, $extra, $code); |
1017
|
|
|
|
|
|
|
sprintf( |
1018
|
|
|
|
|
|
|
'q[%s]->anonymous_generator(%s => { code => %s, named => %d, signature => %s }, toolkit => %s, prefix => %s, factory_package => %s, type_library => %s)', |
1019
|
|
|
|
|
|
|
$me, |
1020
|
|
|
|
|
|
|
$kind, |
1021
|
|
|
|
|
|
|
$munged_code, |
1022
|
|
|
|
|
|
|
!!$signature_is_named, |
1023
|
|
|
|
|
|
|
$type_params_stuff, |
1024
|
|
|
|
|
|
|
B::perlstring($opts->{toolkit}||'Moo'), |
1025
|
|
|
|
|
|
|
B::perlstring($opts->{prefix}), |
1026
|
|
|
|
|
|
|
B::perlstring($opts->{factory_package}), |
1027
|
1
|
|
50
|
|
|
172
|
B::perlstring($opts->{type_library}), |
1028
|
|
|
|
|
|
|
); |
1029
|
|
|
|
|
|
|
} |
1030
|
|
|
|
|
|
|
elsif ($name) { |
1031
|
53
|
50
|
|
|
|
4915
|
$code |
1032
|
|
|
|
|
|
|
? sprintf( |
1033
|
|
|
|
|
|
|
'use MooX::Pression::_Gather -parent => %s; use MooX::Pression::_Gather -gather, %s => q[%s]->_package_callback(sub %s); use MooX::Pression::_Gather -unparent;', |
1034
|
|
|
|
|
|
|
B::perlstring("$plus$name"), |
1035
|
|
|
|
|
|
|
B::perlstring("$kind:$plus$name"), |
1036
|
|
|
|
|
|
|
$me, |
1037
|
|
|
|
|
|
|
$code, |
1038
|
|
|
|
|
|
|
) |
1039
|
|
|
|
|
|
|
: sprintf( |
1040
|
|
|
|
|
|
|
'use MooX::Pression::_Gather -gather, %s => {};', |
1041
|
|
|
|
|
|
|
B::perlstring("$kind:$plus$name"), |
1042
|
|
|
|
|
|
|
); |
1043
|
|
|
|
|
|
|
} |
1044
|
|
|
|
|
|
|
else { |
1045
|
4
|
|
50
|
|
|
19
|
$code ||= '{}'; |
1046
|
|
|
|
|
|
|
sprintf( |
1047
|
|
|
|
|
|
|
'q[%s]->anonymous_package(%s => sub { do %s }, toolkit => %s, prefix => %s, factory_package => %s, type_library => %s)', |
1048
|
|
|
|
|
|
|
$me, |
1049
|
|
|
|
|
|
|
$kind, |
1050
|
|
|
|
|
|
|
$code, |
1051
|
|
|
|
|
|
|
B::perlstring($opts->{toolkit}||'Moo'), |
1052
|
|
|
|
|
|
|
B::perlstring($opts->{prefix}), |
1053
|
|
|
|
|
|
|
B::perlstring($opts->{factory_package}), |
1054
|
4
|
|
50
|
|
|
333
|
B::perlstring($opts->{type_library}), |
1055
|
|
|
|
|
|
|
); |
1056
|
|
|
|
|
|
|
} |
1057
|
|
|
|
|
|
|
} |
1058
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
sub _handle_has_keyword { |
1060
|
25
|
|
|
25
|
|
99
|
my ($me, $name, $rawspec, $default) = @_; |
1061
|
|
|
|
|
|
|
|
1062
|
25
|
100
|
|
|
|
98
|
$rawspec = '()' if !defined $rawspec; |
1063
|
|
|
|
|
|
|
|
1064
|
25
|
50
|
66
|
|
|
186
|
if (defined $default and $default =~ /\$self/) { |
|
|
100
|
|
|
|
|
|
1065
|
0
|
|
|
|
|
0
|
$rawspec = "lazy => !!1, default => sub { my \$self = \$_[0]; $default }, $rawspec"; |
1066
|
|
|
|
|
|
|
} |
1067
|
|
|
|
|
|
|
elsif (defined $default) { |
1068
|
4
|
|
|
|
|
15
|
$rawspec = "default => sub { $default }, $rawspec"; |
1069
|
|
|
|
|
|
|
} |
1070
|
|
|
|
|
|
|
|
1071
|
25
|
|
|
|
|
89
|
$name =~ s/^\+\*/+/; |
1072
|
25
|
|
|
|
|
62
|
$name =~ s/^\*//; |
1073
|
|
|
|
|
|
|
|
1074
|
25
|
100
|
|
|
|
2567
|
sprintf( |
1075
|
|
|
|
|
|
|
'q[%s]->_has(scalar(%s), %s)', |
1076
|
|
|
|
|
|
|
$me, |
1077
|
|
|
|
|
|
|
($name =~ /^\{/) ? "do $name" : B::perlstring($name), |
1078
|
|
|
|
|
|
|
$rawspec, |
1079
|
|
|
|
|
|
|
); |
1080
|
|
|
|
|
|
|
} |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
sub _handle_requires_keyword { |
1083
|
3
|
|
|
3
|
|
12
|
my ($me, $name, $has_sig, $sig) = @_; |
1084
|
3
|
50
|
|
|
|
34
|
my $r1 = sprintf( |
1085
|
|
|
|
|
|
|
'q[%s]->_requires(%s);', |
1086
|
|
|
|
|
|
|
$me, |
1087
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
1088
|
|
|
|
|
|
|
); |
1089
|
3
|
|
|
|
|
8
|
my $r2 = ''; |
1090
|
3
|
100
|
|
|
|
12
|
if (STRICT and $has_sig) { |
1091
|
2
|
|
|
|
|
9
|
my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig); |
1092
|
2
|
50
|
|
|
|
31
|
$r2 = sprintf( |
1093
|
|
|
|
|
|
|
'q[%s]->_modifier(q(around), %s, { caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });', |
1094
|
|
|
|
|
|
|
$me, |
1095
|
|
|
|
|
|
|
($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)), |
1096
|
|
|
|
|
|
|
'sub { my $next = shift; goto $next }', |
1097
|
|
|
|
|
|
|
!!$signature_is_named, |
1098
|
|
|
|
|
|
|
$type_params_stuff, |
1099
|
|
|
|
|
|
|
1, |
1100
|
|
|
|
|
|
|
); |
1101
|
|
|
|
|
|
|
} |
1102
|
3
|
|
|
|
|
484
|
"$r1$r2"; |
1103
|
|
|
|
|
|
|
} |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
sub _syntax_error { |
1106
|
0
|
|
|
0
|
|
0
|
my $ref = pop; |
1107
|
0
|
|
|
|
|
0
|
my ($me, $kind, @poss) = @_; |
1108
|
0
|
|
|
|
|
0
|
require Carp; |
1109
|
0
|
|
|
|
|
0
|
Carp::croak( |
1110
|
|
|
|
|
|
|
"Unexpected syntax in $kind.\n" . |
1111
|
|
|
|
|
|
|
"Expected:\n" . |
1112
|
|
|
|
|
|
|
join("", map "\t$_\n", @poss) . |
1113
|
|
|
|
|
|
|
"Got:\n" . |
1114
|
|
|
|
|
|
|
"\t" . substr($$ref, 0, 32) |
1115
|
|
|
|
|
|
|
); |
1116
|
|
|
|
|
|
|
} |
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
# |
1119
|
|
|
|
|
|
|
# KEYWORDS/UTILITIES |
1120
|
|
|
|
|
|
|
# |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
sub import { |
1123
|
19
|
|
|
19
|
|
188
|
no warnings 'closure'; |
|
19
|
|
|
|
|
64
|
|
|
19
|
|
|
|
|
19388
|
|
1124
|
25
|
|
|
25
|
|
23560
|
my ($me, %opts) = (shift, @_); |
1125
|
25
|
|
33
|
|
|
318
|
my $caller = ($opts{caller} ||= caller); |
1126
|
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
|
# Need to reproduce this logic from MooX::Press to find out |
1128
|
|
|
|
|
|
|
# the name of the type library. |
1129
|
|
|
|
|
|
|
# |
1130
|
25
|
|
|
|
|
530
|
require MooX::Press; |
1131
|
25
|
100
|
|
|
|
168
|
$opts{prefix} = $opts{caller} unless exists $opts{prefix}; |
1132
|
25
|
50
|
|
|
|
125
|
$opts{factory_package} = $opts{prefix} unless exists $opts{factory_package}; |
1133
|
25
|
50
|
|
|
|
216
|
$opts{type_library} = 'Types' unless exists $opts{type_library}; |
1134
|
25
|
|
|
|
|
198
|
$opts{type_library} = 'MooX::Press'->qualify_name($opts{type_library}, $opts{prefix}); |
1135
|
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
|
# Optionally export wrapper subs for pre-declared types |
1137
|
|
|
|
|
|
|
# |
1138
|
25
|
50
|
|
|
|
708
|
if ($opts{declare}) { |
1139
|
0
|
|
|
|
|
0
|
my $types = $opts{type_library}; |
1140
|
0
|
|
|
|
|
0
|
for my $name (@{ $opts{declare} }) { |
|
0
|
|
|
|
|
0
|
|
1141
|
0
|
0
|
|
|
|
0
|
eval qq{ |
1142
|
|
|
|
|
|
|
sub $caller\::$name () { goto \\&$types\::$name } |
1143
|
|
|
|
|
|
|
sub $caller\::is_$name (\$) { goto \\&$types\::is_$name } |
1144
|
|
|
|
|
|
|
sub $caller\::assert_$name (\$) { goto \\&$types\::assert_$name } |
1145
|
|
|
|
|
|
|
1; |
1146
|
|
|
|
|
|
|
} or die($@); |
1147
|
|
|
|
|
|
|
} |
1148
|
|
|
|
|
|
|
} |
1149
|
|
|
|
|
|
|
|
1150
|
|
|
|
|
|
|
# Export utility stuff |
1151
|
|
|
|
|
|
|
# |
1152
|
25
|
|
|
|
|
373
|
MooX::Pression::_Gather->import::into($caller, -gather => %opts); |
1153
|
25
|
|
|
|
|
449
|
MooX::Press::Keywords->import::into($caller, qw( -booleans -privacy -util )); # imports strict and warnings |
1154
|
25
|
|
|
|
|
63409
|
Syntax::Keyword::Try->import::into($caller); |
1155
|
25
|
50
|
|
|
|
5858
|
if ($] >= 5.018) { |
|
|
0
|
|
|
|
|
|
1156
|
25
|
|
|
|
|
230
|
feature->import::into($caller, qw( say state unicode_strings unicode_eval evalbytes current_sub fc )); |
1157
|
|
|
|
|
|
|
} |
1158
|
|
|
|
|
|
|
elsif ($] >= 5.014) { |
1159
|
0
|
|
|
|
|
0
|
feature->import::into($caller, qw( say state unicode_strings )); |
1160
|
|
|
|
|
|
|
} |
1161
|
|
|
|
|
|
|
$_->import::into($caller, qw( -types -is -assert )) |
1162
|
25
|
|
|
|
|
7580
|
for qw(Types::Standard Types::Common::Numeric Types::Common::String); |
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
# `include` keyword |
1165
|
|
|
|
|
|
|
# |
1166
|
|
|
|
|
|
|
Keyword::Simple::define include => sub { |
1167
|
2
|
|
|
2
|
|
5
|
my $ref = shift; |
1168
|
|
|
|
|
|
|
|
1169
|
2
|
50
|
|
|
|
8
|
$$ref =~ _fetch_re('MxpIncludeSyntax', anchor => 'start') or $me->_syntax_error( |
1170
|
|
|
|
|
|
|
'include directive', |
1171
|
|
|
|
|
|
|
'include <name>', |
1172
|
|
|
|
|
|
|
$ref, |
1173
|
|
|
|
|
|
|
); |
1174
|
|
|
|
|
|
|
|
1175
|
2
|
|
|
|
|
44
|
my ($pos, $name) = ($+[0], $+{name}); |
1176
|
2
|
|
|
|
|
30
|
my $qualified = 'MooX::Press'->qualify_name($name, $opts{prefix}); |
1177
|
2
|
|
|
|
|
340
|
substr($$ref, 0, $pos) = sprintf('BEGIN { eval(q[%s]->_include(%s)) or die($@) };', $me, B::perlstring($qualified)); |
1178
|
25
|
|
|
|
|
575165
|
}; |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
# `class` keyword |
1181
|
|
|
|
|
|
|
# |
1182
|
|
|
|
|
|
|
Keyword::Simple::define class => sub { |
1183
|
57
|
|
|
57
|
|
7015
|
my $ref = shift; |
1184
|
|
|
|
|
|
|
|
1185
|
57
|
50
|
|
|
|
379
|
$$ref =~ _fetch_re('MxpClassSyntax', anchor => 'start') or $me->_syntax_error( |
1186
|
|
|
|
|
|
|
'class declaration', |
1187
|
|
|
|
|
|
|
'class <name> (<signature>) { <block> }', |
1188
|
|
|
|
|
|
|
'class <name> { <block> }', |
1189
|
|
|
|
|
|
|
'class <name>', |
1190
|
|
|
|
|
|
|
'class (<signature>) { <block> }', |
1191
|
|
|
|
|
|
|
'class { <block> }', |
1192
|
|
|
|
|
|
|
'class;', |
1193
|
|
|
|
|
|
|
$ref, |
1194
|
|
|
|
|
|
|
); |
1195
|
|
|
|
|
|
|
|
1196
|
57
|
|
|
|
|
81027
|
my ($pos, $plus, $name, $sig, $block) = ($+[0], $+{plus}, $+{name}, $+{sig}, $+{block}); |
1197
|
57
|
|
|
|
|
404
|
my $has_sig = !!exists $+{sig}; |
1198
|
57
|
|
100
|
|
|
403
|
$plus ||= ''; |
1199
|
57
|
|
100
|
|
|
191
|
$block ||= '{}'; |
1200
|
|
|
|
|
|
|
|
1201
|
57
|
|
|
|
|
364
|
substr($$ref, 0, $pos) = $me->_handle_package_keyword(class => $name, $block, $has_sig, $sig, $plus, \%opts); |
1202
|
25
|
|
|
|
|
899
|
}; |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
Keyword::Simple::define abstract => sub { |
1205
|
1
|
|
|
1
|
|
373
|
my $ref = shift; |
1206
|
|
|
|
|
|
|
|
1207
|
1
|
50
|
|
|
|
12
|
$$ref =~ _fetch_re('MxpAbstractSyntax', anchor => 'start') or $me->_syntax_error( |
1208
|
|
|
|
|
|
|
'abstract class declaration', |
1209
|
|
|
|
|
|
|
'abstract class <name> (<signature>) { <block> }', |
1210
|
|
|
|
|
|
|
'abstract class <name> { <block> }', |
1211
|
|
|
|
|
|
|
'abstract class <name>', |
1212
|
|
|
|
|
|
|
'abstract class (<signature>) { <block> }', |
1213
|
|
|
|
|
|
|
'abstract class { <block> }', |
1214
|
|
|
|
|
|
|
'abstract class;', |
1215
|
|
|
|
|
|
|
$ref, |
1216
|
|
|
|
|
|
|
); |
1217
|
|
|
|
|
|
|
|
1218
|
1
|
|
|
|
|
37
|
my ($pos, $plus, $name, $sig, $block) = ($+[0], $+{plus}, $+{name}, $+{sig}, $+{block}); |
1219
|
1
|
|
|
|
|
10
|
my $has_sig = !!exists $+{sig}; |
1220
|
1
|
|
50
|
|
|
9
|
$plus ||= ''; |
1221
|
1
|
|
50
|
|
|
6
|
$block ||= '{}'; |
1222
|
|
|
|
|
|
|
|
1223
|
1
|
|
|
|
|
9
|
substr($$ref, 0, $pos) = $me->_handle_package_keyword(abstract => $name, $block, $has_sig, $sig, $plus, \%opts); |
1224
|
25
|
|
|
|
|
585
|
}; |
1225
|
|
|
|
|
|
|
|
1226
|
25
|
|
|
|
|
452
|
for my $kw (qw/ role interface /) { |
1227
|
|
|
|
|
|
|
Keyword::Simple::define $kw => sub { |
1228
|
7
|
|
|
7
|
|
1808
|
my $ref = shift; |
1229
|
|
|
|
|
|
|
|
1230
|
7
|
50
|
|
|
|
47
|
$$ref =~ _fetch_re('MxpRoleSyntax', anchor => 'start') or $me->_syntax_error( |
1231
|
|
|
|
|
|
|
"$kw declaration", |
1232
|
|
|
|
|
|
|
"$kw <name> (<signature>) { <block> }", |
1233
|
|
|
|
|
|
|
"$kw <name> { <block> }", |
1234
|
|
|
|
|
|
|
"$kw <name>", |
1235
|
|
|
|
|
|
|
"$kw (<signature>) { <block> }", |
1236
|
|
|
|
|
|
|
"$kw { <block> }", |
1237
|
|
|
|
|
|
|
"$kw;", |
1238
|
|
|
|
|
|
|
$ref, |
1239
|
|
|
|
|
|
|
); |
1240
|
|
|
|
|
|
|
|
1241
|
7
|
|
|
|
|
7957
|
my ($pos, $name, $sig, $block) = ($+[0], $+{name}, $+{sig}, $+{block}); |
1242
|
7
|
|
|
|
|
56
|
my $has_sig = !!exists $+{sig}; |
1243
|
7
|
|
50
|
|
|
33
|
$block ||= '{}'; |
1244
|
|
|
|
|
|
|
|
1245
|
7
|
|
|
|
|
50
|
substr($$ref, 0, $pos) = $me->_handle_package_keyword($kw => $name, $block, $has_sig, $sig, '', \%opts); |
1246
|
50
|
|
|
|
|
639
|
}; |
1247
|
|
|
|
|
|
|
} |
1248
|
|
|
|
|
|
|
|
1249
|
|
|
|
|
|
|
Keyword::Simple::define toolkit => sub { |
1250
|
0
|
|
|
0
|
|
0
|
my $ref = shift; |
1251
|
|
|
|
|
|
|
|
1252
|
0
|
0
|
|
|
|
0
|
$$ref =~ _fetch_re('MxpToolkitSyntax', anchor => 'start') or $me->_syntax_error( |
1253
|
|
|
|
|
|
|
'toolkit declaration', |
1254
|
|
|
|
|
|
|
'toolkit <toolkit> (<extensions>)', |
1255
|
|
|
|
|
|
|
'toolkit <toolkit>;', |
1256
|
|
|
|
|
|
|
$ref, |
1257
|
|
|
|
|
|
|
); |
1258
|
|
|
|
|
|
|
|
1259
|
0
|
|
|
|
|
0
|
my ($pos, $name, $imports) = ($+[0], $+{name}, $+{imports}); |
1260
|
|
|
|
|
|
|
|
1261
|
0
|
0
|
|
|
|
0
|
if ($imports) { |
1262
|
0
|
|
|
|
|
0
|
my @imports = grep defined, |
1263
|
|
|
|
|
|
|
($imports =~ / ((?&PerlQualifiedIdentifier)|(?&PerlComma)) $GRAMMAR /xg); |
1264
|
0
|
|
|
|
|
0
|
my @processed_imports; |
1265
|
0
|
|
|
|
|
0
|
while (@imports) { |
1266
|
19
|
|
|
19
|
|
164
|
no warnings 'uninitialized'; |
|
19
|
|
|
|
|
46
|
|
|
19
|
|
|
|
|
67155
|
|
1267
|
0
|
|
|
|
|
0
|
my $next = shift @imports; |
1268
|
0
|
0
|
|
|
|
0
|
if ($next =~ /^::(.+)$/) { |
|
|
0
|
|
|
|
|
|
1269
|
0
|
|
|
|
|
0
|
push @processed_imports, $1; |
1270
|
|
|
|
|
|
|
} |
1271
|
|
|
|
|
|
|
elsif ($next =~ /^[^\W0-9]/) { |
1272
|
0
|
|
|
|
|
0
|
push @processed_imports, sprintf('%sX::%s', $name, $next); |
1273
|
|
|
|
|
|
|
} |
1274
|
|
|
|
|
|
|
else { |
1275
|
0
|
|
|
|
|
0
|
die "Expected package name, got $next"; |
1276
|
|
|
|
|
|
|
} |
1277
|
0
|
0
|
|
|
|
0
|
$imports[0] eq ',' and shift @imports; |
1278
|
|
|
|
|
|
|
} |
1279
|
0
|
|
|
|
|
0
|
substr($$ref, 0, $pos) = sprintf('q[%s]->_toolkit(%s);', $me, join ",", map(B::perlstring($_), $name, @processed_imports)); |
1280
|
|
|
|
|
|
|
} |
1281
|
|
|
|
|
|
|
|
1282
|
|
|
|
|
|
|
else { |
1283
|
0
|
|
|
|
|
0
|
substr($$ref, 0, $pos) = sprintf('q[%s]->_toolkit(%s);', $me, B::perlstring($name)); |
1284
|
|
|
|
|
|
|
} |
1285
|
25
|
|
|
|
|
584
|
}; |
1286
|
|
|
|
|
|
|
|
1287
|
|
|
|
|
|
|
# `begin` and `end` keywords |
1288
|
|
|
|
|
|
|
# |
1289
|
25
|
|
|
|
|
452
|
for my $kw (qw/ begin end /) { |
1290
|
|
|
|
|
|
|
Keyword::Simple::define $kw => sub { |
1291
|
0
|
|
|
0
|
|
0
|
my $ref = shift; |
1292
|
|
|
|
|
|
|
|
1293
|
0
|
0
|
|
|
|
0
|
$$ref =~ _fetch_re('MxpHookSyntax', anchor => 'start') or $me->_syntax_error( |
1294
|
|
|
|
|
|
|
"$kw hook", |
1295
|
|
|
|
|
|
|
"$kw { <block> }", |
1296
|
|
|
|
|
|
|
$ref, |
1297
|
|
|
|
|
|
|
); |
1298
|
|
|
|
|
|
|
|
1299
|
0
|
|
|
|
|
0
|
my ($pos, $capture) = ($+[0], $+{hook}); |
1300
|
0
|
|
|
|
|
0
|
substr($$ref, 0, $pos) = sprintf('q[%s]->_begin(sub { my ($package, $kind) = (shift, @_); do %s });', $me, $capture); |
1301
|
50
|
|
|
|
|
650
|
}; |
1302
|
|
|
|
|
|
|
} |
1303
|
|
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
# `type_name` keyword |
1305
|
|
|
|
|
|
|
# |
1306
|
|
|
|
|
|
|
Keyword::Simple::define type_name => sub { |
1307
|
1
|
|
|
1
|
|
4
|
my $ref = shift; |
1308
|
|
|
|
|
|
|
|
1309
|
1
|
50
|
|
|
|
5
|
$$ref =~ _fetch_re('MxpTypeNameSyntax', anchor => 'start') or $me->_syntax_error( |
1310
|
|
|
|
|
|
|
'type name declaration', |
1311
|
|
|
|
|
|
|
'type_name <identifier>', |
1312
|
|
|
|
|
|
|
$ref, |
1313
|
|
|
|
|
|
|
); |
1314
|
|
|
|
|
|
|
|
1315
|
1
|
|
|
|
|
19
|
my ($pos, $capture) = ($+[0], $+{name}); |
1316
|
1
|
|
|
|
|
90
|
substr($$ref, 0, $pos) = sprintf('q[%s]->_type_name(%s);', $me, B::perlstring($capture)); |
1317
|
25
|
|
|
|
|
677
|
}; |
1318
|
|
|
|
|
|
|
|
1319
|
|
|
|
|
|
|
# `extends` keyword |
1320
|
|
|
|
|
|
|
# |
1321
|
|
|
|
|
|
|
Keyword::Simple::define extends => sub { |
1322
|
7
|
|
|
7
|
|
33
|
my $ref = shift; |
1323
|
|
|
|
|
|
|
|
1324
|
7
|
50
|
|
|
|
35
|
$$ref =~ _fetch_re('MxpExtendsSyntax', anchor => 'start') or $me->_syntax_error( |
1325
|
|
|
|
|
|
|
'extends declaration', |
1326
|
|
|
|
|
|
|
'extends <classes>', |
1327
|
|
|
|
|
|
|
$ref, |
1328
|
|
|
|
|
|
|
); |
1329
|
|
|
|
|
|
|
|
1330
|
7
|
|
|
|
|
388
|
my ($pos, $capture) = ($+[0], $+{list}); |
1331
|
7
|
|
|
|
|
102
|
substr($$ref, 0, $pos) = sprintf('q[%s]->_extends(%s);', $me, $me->_handle_role_list($capture, 'class')); |
1332
|
25
|
|
|
|
|
596
|
}; |
1333
|
|
|
|
|
|
|
|
1334
|
|
|
|
|
|
|
# `with` keyword |
1335
|
|
|
|
|
|
|
# |
1336
|
|
|
|
|
|
|
Keyword::Simple::define with => sub { |
1337
|
7
|
|
|
7
|
|
24
|
my $ref = shift; |
1338
|
|
|
|
|
|
|
|
1339
|
7
|
50
|
|
|
|
33
|
$$ref =~ _fetch_re('MxpWithSyntax', anchor => 'start') or $me->_syntax_error( |
1340
|
|
|
|
|
|
|
'with declaration', |
1341
|
|
|
|
|
|
|
'with <roles>', |
1342
|
|
|
|
|
|
|
$ref, |
1343
|
|
|
|
|
|
|
); |
1344
|
|
|
|
|
|
|
|
1345
|
7
|
|
|
|
|
254
|
my ($pos, $capture) = ($+[0], $+{list}); |
1346
|
|
|
|
|
|
|
|
1347
|
7
|
|
|
|
|
86
|
substr($$ref, 0, $pos) = sprintf('q[%s]->_with(%s);', $me, $me->_handle_role_list($capture, 'role')); |
1348
|
25
|
|
|
|
|
598
|
}; |
1349
|
|
|
|
|
|
|
|
1350
|
|
|
|
|
|
|
# `requires` keyword |
1351
|
|
|
|
|
|
|
# |
1352
|
|
|
|
|
|
|
Keyword::Simple::define requires => sub { |
1353
|
3
|
|
|
3
|
|
14
|
my $ref = shift; |
1354
|
|
|
|
|
|
|
|
1355
|
3
|
50
|
|
|
|
13
|
$$ref =~ _fetch_re('MxpRequiresSyntax', anchor => 'start') or $me->_syntax_error( |
1356
|
|
|
|
|
|
|
'requires declaration', |
1357
|
|
|
|
|
|
|
'requires <name> (<signature>)', |
1358
|
|
|
|
|
|
|
'requires <name>', |
1359
|
|
|
|
|
|
|
$ref, |
1360
|
|
|
|
|
|
|
); |
1361
|
|
|
|
|
|
|
|
1362
|
3
|
|
|
|
|
66
|
my ($pos, $name, $sig) = ($+[0], $+{name}, $+{sig}); |
1363
|
3
|
|
|
|
|
24
|
my $has_sig = !!exists $+{sig}; |
1364
|
3
|
|
|
|
|
30
|
substr($$ref, 0, $pos) = $me->_handle_requires_keyword($name, $has_sig, $sig) |
1365
|
25
|
|
|
|
|
606
|
}; |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
# `has` keyword |
1368
|
|
|
|
|
|
|
# |
1369
|
|
|
|
|
|
|
Keyword::Simple::define has => sub { |
1370
|
25
|
|
|
25
|
|
95
|
my $ref = shift; |
1371
|
|
|
|
|
|
|
|
1372
|
25
|
50
|
|
|
|
122
|
$$ref =~ _fetch_re('MxpHasSyntax', anchor => 'start') or $me->_syntax_error( |
1373
|
|
|
|
|
|
|
'attribute declaration', |
1374
|
|
|
|
|
|
|
'has <name> (<spec>) = <default>', |
1375
|
|
|
|
|
|
|
'has <name> (<spec>)', |
1376
|
|
|
|
|
|
|
'has <name> = <default>', |
1377
|
|
|
|
|
|
|
'has <name>', |
1378
|
|
|
|
|
|
|
$ref, |
1379
|
|
|
|
|
|
|
); |
1380
|
|
|
|
|
|
|
|
1381
|
25
|
|
|
|
|
1368
|
my ($pos, $plus, $name, $postfix, $spec, $default) = ($+[0], $+{plus}, $+{name}, $+{postfix}, $+{spec}, $+{default}); |
1382
|
25
|
|
|
|
|
185
|
my $has_spec = !!exists $+{spec}; |
1383
|
25
|
|
|
|
|
116
|
my $has_default = !!exists $+{default}; |
1384
|
25
|
|
100
|
|
|
169
|
$plus ||= ''; |
1385
|
25
|
|
50
|
|
|
161
|
$postfix ||= ''; |
1386
|
25
|
100
|
|
|
|
336
|
substr($$ref, 0, $pos) = $me->_handle_has_keyword("$plus$name$postfix", $has_spec ? $spec : undef, $has_default ? $default : undef); |
|
|
100
|
|
|
|
|
|
1387
|
25
|
|
|
|
|
608
|
}; |
1388
|
|
|
|
|
|
|
|
1389
|
|
|
|
|
|
|
# `constant` keyword |
1390
|
|
|
|
|
|
|
# |
1391
|
|
|
|
|
|
|
Keyword::Simple::define constant => sub { |
1392
|
6
|
|
|
6
|
|
37
|
my $ref = shift; |
1393
|
|
|
|
|
|
|
|
1394
|
6
|
50
|
|
|
|
36
|
$$ref =~ _fetch_re('MxpConstantSyntax', anchor => 'start') or $me->_syntax_error( |
1395
|
|
|
|
|
|
|
'constant declaration', |
1396
|
|
|
|
|
|
|
'constant <name> = <value>', |
1397
|
|
|
|
|
|
|
$ref, |
1398
|
|
|
|
|
|
|
); |
1399
|
|
|
|
|
|
|
|
1400
|
6
|
|
|
|
|
135
|
my ($pos, $name, $expr) = ($+[0], $+{name}, $+{expr}); |
1401
|
6
|
|
|
|
|
677
|
substr($$ref, 0, $pos) = sprintf('q[%s]->_constant(%s, %s);', $me, B::perlstring($name), $expr); |
1402
|
25
|
|
|
|
|
618
|
}; |
1403
|
|
|
|
|
|
|
|
1404
|
|
|
|
|
|
|
# `method` keyword |
1405
|
|
|
|
|
|
|
# |
1406
|
|
|
|
|
|
|
Keyword::Simple::define method => sub { |
1407
|
11
|
|
|
11
|
|
54
|
my $ref = shift; |
1408
|
|
|
|
|
|
|
|
1409
|
11
|
|
|
|
|
45
|
state $re_attr = _fetch_re('MxpAttribute'); |
1410
|
|
|
|
|
|
|
|
1411
|
11
|
50
|
|
|
|
107
|
$$ref =~ _fetch_re('MxpMethodSyntax', anchor => 'start') or $me->_syntax_error( |
1412
|
|
|
|
|
|
|
'method declaration', |
1413
|
|
|
|
|
|
|
'method <name> <attributes> (<signature>) { <block> }', |
1414
|
|
|
|
|
|
|
'method <name> (<signature>) { <block> }', |
1415
|
|
|
|
|
|
|
'method <name> <attributes> { <block> }', |
1416
|
|
|
|
|
|
|
'method <name> { <block> }', |
1417
|
|
|
|
|
|
|
'method <attributes> (<signature>) { <block> }', |
1418
|
|
|
|
|
|
|
'method (<signature>) { <block> }', |
1419
|
|
|
|
|
|
|
'method <attributes> { <block> }', |
1420
|
|
|
|
|
|
|
'method { <block> }', |
1421
|
|
|
|
|
|
|
$ref, |
1422
|
|
|
|
|
|
|
); |
1423
|
|
|
|
|
|
|
|
1424
|
11
|
|
|
|
|
18090
|
my ($pos, $name, $attributes, $sig, $code) = ($+[0], $+{name}, $+{attributes}, $+{sig}, $+{code}); |
1425
|
11
|
|
|
|
|
95
|
my $has_sig = !!exists $+{sig}; |
1426
|
11
|
100
|
|
|
|
43415
|
my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : (); |
1427
|
|
|
|
|
|
|
|
1428
|
11
|
|
|
|
|
252
|
substr($$ref, 0, $pos) = $me->_handle_method_keyword($name, $code, $has_sig, $sig, \@attrs); |
1429
|
25
|
|
|
|
|
631
|
}; |
1430
|
|
|
|
|
|
|
|
1431
|
|
|
|
|
|
|
# `multi` keyword |
1432
|
|
|
|
|
|
|
# |
1433
|
|
|
|
|
|
|
Keyword::Simple::define multi => sub { |
1434
|
0
|
|
|
0
|
|
0
|
my $ref = shift; |
1435
|
|
|
|
|
|
|
|
1436
|
0
|
|
|
|
|
0
|
state $re_attr = _fetch_re('MxpAttribute'); |
1437
|
|
|
|
|
|
|
|
1438
|
0
|
0
|
|
|
|
0
|
$$ref =~ _fetch_re('MxpMultiSyntax', anchor => 'start') or $me->_syntax_error( |
1439
|
|
|
|
|
|
|
'multimethod declaration', |
1440
|
|
|
|
|
|
|
'multi method <name> <attributes> (<signature>) { <block> }', |
1441
|
|
|
|
|
|
|
'multi method <name> (<signature>) { <block> }', |
1442
|
|
|
|
|
|
|
'multi method <name> <attributes> { <block> }', |
1443
|
|
|
|
|
|
|
'multi method <name> { <block> }', |
1444
|
|
|
|
|
|
|
$ref, |
1445
|
|
|
|
|
|
|
); |
1446
|
|
|
|
|
|
|
|
1447
|
0
|
|
|
|
|
0
|
my ($pos, $name, $attributes, $sig, $code) = ($+[0], $+{name}, $+{attributes}, $+{sig}, $+{code}); |
1448
|
0
|
|
|
|
|
0
|
my $has_sig = !!exists $+{sig}; |
1449
|
0
|
0
|
|
|
|
0
|
my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : (); |
1450
|
|
|
|
|
|
|
|
1451
|
0
|
|
|
|
|
0
|
substr($$ref, 0, $pos) = $me->_handle_multimethod_keyword($name, $code, $has_sig, $sig, \@attrs); |
1452
|
25
|
|
|
|
|
621
|
}; |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
# `before`, `after`, and `around` keywords |
1455
|
|
|
|
|
|
|
# |
1456
|
25
|
|
|
|
|
551
|
for my $kw (qw( before after around )) { |
1457
|
|
|
|
|
|
|
Keyword::Simple::define $kw => sub { |
1458
|
1
|
|
|
1
|
|
5
|
my $ref = shift; |
1459
|
|
|
|
|
|
|
|
1460
|
1
|
|
|
|
|
5
|
state $re_attr = _fetch_re('MxpAttribute'); |
1461
|
|
|
|
|
|
|
|
1462
|
1
|
50
|
|
|
|
4
|
$$ref =~ _fetch_re('MxpModifierSyntax', anchor => 'start') or $me->_syntax_error( |
1463
|
|
|
|
|
|
|
"$kw method modifier declaration", |
1464
|
|
|
|
|
|
|
"$kw <name> <attributes> (<signature>) { <block> }", |
1465
|
|
|
|
|
|
|
"$kw <name> (<signature>) { <block> }", |
1466
|
|
|
|
|
|
|
"$kw <name> <attributes> { <block> }", |
1467
|
|
|
|
|
|
|
"$kw <name> { <block> }", |
1468
|
|
|
|
|
|
|
$ref, |
1469
|
|
|
|
|
|
|
); |
1470
|
|
|
|
|
|
|
|
1471
|
1
|
|
|
|
|
711
|
my ($pos, $name, $attributes, $sig, $code) = ($+[0], $+{name}, $+{attributes}, $+{sig}, $+{code}); |
1472
|
1
|
|
|
|
|
8
|
my $has_sig = !!exists $+{sig}; |
1473
|
1
|
50
|
|
|
|
7
|
my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : (); |
1474
|
|
|
|
|
|
|
|
1475
|
1
|
|
|
|
|
12
|
substr($$ref, 0, $pos) = $me->_handle_modifier_keyword($kw, $name, $code, $has_sig, $sig, \@attrs); |
1476
|
75
|
|
|
|
|
1362
|
}; |
1477
|
|
|
|
|
|
|
} |
1478
|
|
|
|
|
|
|
|
1479
|
|
|
|
|
|
|
Keyword::Simple::define factory => sub { |
1480
|
2
|
|
|
2
|
|
8
|
my $ref = shift; |
1481
|
|
|
|
|
|
|
|
1482
|
2
|
50
|
|
|
|
11
|
if ( $$ref =~ _fetch_re('MxpFactorySyntax', anchor => 'start') ) { |
1483
|
2
|
|
|
|
|
2699
|
state $re_attr = _fetch_re('MxpAttribute'); |
1484
|
2
|
|
|
|
|
66
|
my ($pos, $name, $attributes, $sig, $code) = ($+[0], $+{name}, $+{attributes}, $+{sig}, $+{code}); |
1485
|
2
|
|
|
|
|
18
|
my $has_sig = !!exists $+{sig}; |
1486
|
2
|
50
|
|
|
|
13
|
my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : (); |
1487
|
2
|
|
|
|
|
25
|
substr($$ref, 0, $pos) = $me->_handle_factory_keyword($name, undef, $code, $has_sig, $sig, \@attrs); |
1488
|
2
|
|
|
|
|
416
|
return; |
1489
|
|
|
|
|
|
|
} |
1490
|
|
|
|
|
|
|
|
1491
|
0
|
0
|
|
|
|
0
|
$$ref =~ _fetch_re('MxpFactoryViaSyntax', anchor => 'start') or $me->_syntax_error( |
1492
|
|
|
|
|
|
|
'factory method declaration', |
1493
|
|
|
|
|
|
|
'factory <name> <attributes> (<signature>) { <block> }', |
1494
|
|
|
|
|
|
|
'factory <name> (<signature>) { <block> }', |
1495
|
|
|
|
|
|
|
'factory <name> <attributes> { <block> }', |
1496
|
|
|
|
|
|
|
'factory <name> { <block> }', |
1497
|
|
|
|
|
|
|
'factory <name> via <methodname>', |
1498
|
|
|
|
|
|
|
'factory <name>', |
1499
|
|
|
|
|
|
|
$ref, |
1500
|
|
|
|
|
|
|
); |
1501
|
|
|
|
|
|
|
|
1502
|
0
|
|
|
|
|
0
|
my ($pos, $name, $via) = ($+[0], $+{name}, $+{via}); |
1503
|
0
|
|
0
|
|
|
0
|
$via ||= 'new'; |
1504
|
0
|
|
|
|
|
0
|
substr($$ref, 0, $pos) = $me->_handle_factory_keyword($name, $via, undef, undef, undef, []); |
1505
|
25
|
|
|
|
|
715
|
}; |
1506
|
|
|
|
|
|
|
|
1507
|
|
|
|
|
|
|
Keyword::Simple::define coerce => sub { |
1508
|
1
|
|
|
1
|
|
5
|
my $ref = shift; |
1509
|
|
|
|
|
|
|
|
1510
|
1
|
50
|
|
|
|
17
|
$$ref =~ _fetch_re('MxpCoerceSyntax', anchor => 'start') or $me->_syntax_error( |
1511
|
|
|
|
|
|
|
'coercion declaration', |
1512
|
|
|
|
|
|
|
'coerce from <type> via <method_name> { <block> }', |
1513
|
|
|
|
|
|
|
'coerce from <type> via <method_name>', |
1514
|
|
|
|
|
|
|
$ref, |
1515
|
|
|
|
|
|
|
); |
1516
|
|
|
|
|
|
|
|
1517
|
1
|
|
|
|
|
1054
|
my ($pos, $from, $via, $code) = ($+[0], $+{from}, $+{via}, $+{code}); |
1518
|
1
|
50
|
|
|
|
13
|
if ($from =~ /^\{/) { |
|
|
50
|
|
|
|
|
|
1519
|
0
|
|
|
|
|
0
|
$from = "scalar(do $from)" |
1520
|
|
|
|
|
|
|
} |
1521
|
|
|
|
|
|
|
elsif ($from !~ /^(q\b)|(qq\b)|"|'/) { |
1522
|
1
|
|
|
|
|
8
|
$from = B::perlstring($from); |
1523
|
|
|
|
|
|
|
} |
1524
|
1
|
50
|
|
|
|
12
|
if ($via =~ /^\{/) { |
|
|
50
|
|
|
|
|
|
1525
|
0
|
|
|
|
|
0
|
$via = "scalar(do $via)" |
1526
|
|
|
|
|
|
|
} |
1527
|
|
|
|
|
|
|
elsif ($via !~ /^(q\b)|(qq\b)|"|'/) { |
1528
|
1
|
|
|
|
|
4
|
$via = B::perlstring($via); |
1529
|
|
|
|
|
|
|
} |
1530
|
|
|
|
|
|
|
|
1531
|
1
|
50
|
|
|
|
175
|
substr($$ref, 0, $pos) = sprintf('q[%s]->_coerce(%s, %s, %s);', $me, $from, $via, $code ? "sub { my \$class; local \$_; (\$class, \$_) = \@_; do $code }" : ''); |
1532
|
25
|
|
|
|
|
736
|
}; |
1533
|
|
|
|
|
|
|
|
1534
|
|
|
|
|
|
|
# Go! |
1535
|
|
|
|
|
|
|
# |
1536
|
|
|
|
|
|
|
on_scope_end { |
1537
|
19
|
100
|
|
19
|
|
168
|
eval "package $caller; use MooX::Pression::_Gather -go; 1" |
|
19
|
|
|
25
|
|
42
|
|
|
19
|
|
|
|
|
107
|
|
|
25
|
|
|
|
|
3004
|
|
1538
|
|
|
|
|
|
|
or Carp::croak($@); |
1539
|
25
|
|
|
|
|
783
|
}; |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
# Need this to export `authority` and `version`... |
1542
|
25
|
|
|
|
|
698
|
@_ = ($me); |
1543
|
25
|
|
|
|
|
140
|
goto \&Exporter::Tiny::import; |
1544
|
|
|
|
|
|
|
} |
1545
|
|
|
|
|
|
|
|
1546
|
|
|
|
|
|
|
our %OPTS; |
1547
|
|
|
|
|
|
|
|
1548
|
|
|
|
|
|
|
# `version` keyword |
1549
|
|
|
|
|
|
|
# |
1550
|
|
|
|
|
|
|
sub version { |
1551
|
0
|
|
|
0
|
1
|
0
|
$OPTS{version} = shift; |
1552
|
|
|
|
|
|
|
} |
1553
|
|
|
|
|
|
|
|
1554
|
|
|
|
|
|
|
# `authority` keyword |
1555
|
|
|
|
|
|
|
# |
1556
|
|
|
|
|
|
|
sub authority { |
1557
|
0
|
|
|
0
|
1
|
0
|
$OPTS{authority} = shift; |
1558
|
|
|
|
|
|
|
} |
1559
|
|
|
|
|
|
|
|
1560
|
|
|
|
|
|
|
# `overload` keyword |
1561
|
|
|
|
|
|
|
# |
1562
|
|
|
|
|
|
|
sub overload { |
1563
|
1
|
50
|
33
|
1
|
1
|
15
|
if (@_ == 1 and ref($_[0]) eq 'HASH') { |
|
|
50
|
33
|
|
|
|
|
1564
|
0
|
|
0
|
|
|
0
|
push @{ $OPTS{overload} ||= [] }, %{+shift}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1565
|
|
|
|
|
|
|
} |
1566
|
|
|
|
|
|
|
elsif (@_ == 1 and ref($_[0]) eq 'ARRAY') { |
1567
|
0
|
|
0
|
|
|
0
|
push @{ $OPTS{overload} ||= [] }, @{+shift}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1568
|
|
|
|
|
|
|
} |
1569
|
|
|
|
|
|
|
else { |
1570
|
1
|
|
50
|
|
|
3
|
push @{ $OPTS{overload} ||= [] }, @_; |
|
1
|
|
|
|
|
10
|
|
1571
|
|
|
|
|
|
|
} |
1572
|
|
|
|
|
|
|
} |
1573
|
|
|
|
|
|
|
|
1574
|
|
|
|
|
|
|
# `MooX::Pression::PACKAGE_SPEC` keyword |
1575
|
|
|
|
|
|
|
# |
1576
|
1
|
|
|
1
|
1
|
12
|
sub PACKAGE_SPEC { \%OPTS } |
1577
|
|
|
|
|
|
|
|
1578
|
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
|
# |
1580
|
|
|
|
|
|
|
# CALLBACKS |
1581
|
|
|
|
|
|
|
# |
1582
|
|
|
|
|
|
|
|
1583
|
|
|
|
|
|
|
sub _package_callback { |
1584
|
66
|
|
|
66
|
|
236798
|
shift; |
1585
|
66
|
|
|
|
|
157
|
my $cb = shift; |
1586
|
66
|
|
|
|
|
211
|
local %OPTS = (); |
1587
|
66
|
|
|
|
|
295
|
&$cb; |
1588
|
|
|
|
|
|
|
# use Data::Dumper; |
1589
|
|
|
|
|
|
|
# $Data::Dumper::Deparse = 1; |
1590
|
|
|
|
|
|
|
# print "OPTS:".Dumper $cb, +{ %OPTS }; |
1591
|
66
|
|
|
|
|
653
|
return +{ %OPTS }; |
1592
|
|
|
|
|
|
|
} |
1593
|
|
|
|
|
|
|
sub _has { |
1594
|
28
|
|
|
28
|
|
242
|
shift; |
1595
|
28
|
|
|
|
|
107
|
my ($attr, %spec) = @_; |
1596
|
28
|
|
|
|
|
131
|
$OPTS{has}{$attr} = \%spec; |
1597
|
|
|
|
|
|
|
} |
1598
|
|
|
|
|
|
|
sub _extends { |
1599
|
8
|
|
|
8
|
|
85
|
shift; |
1600
|
8
|
|
50
|
|
|
46
|
@{ $OPTS{extends}||=[] } = @_; |
|
8
|
|
|
|
|
91
|
|
1601
|
|
|
|
|
|
|
} |
1602
|
|
|
|
|
|
|
sub _type_name { |
1603
|
1
|
|
|
1
|
|
7
|
shift; |
1604
|
1
|
|
|
|
|
6
|
$OPTS{type_name} = shift; |
1605
|
|
|
|
|
|
|
} |
1606
|
|
|
|
|
|
|
sub _begin { |
1607
|
0
|
|
|
0
|
|
0
|
shift; |
1608
|
0
|
|
|
|
|
0
|
$OPTS{begin} = shift; |
1609
|
|
|
|
|
|
|
} |
1610
|
|
|
|
|
|
|
sub _end { |
1611
|
0
|
|
|
0
|
|
0
|
shift; |
1612
|
0
|
|
|
|
|
0
|
$OPTS{end} = shift; |
1613
|
|
|
|
|
|
|
} |
1614
|
|
|
|
|
|
|
sub _interface { |
1615
|
0
|
|
|
0
|
|
0
|
shift; |
1616
|
0
|
|
|
|
|
0
|
$OPTS{interface} = shift; |
1617
|
|
|
|
|
|
|
} |
1618
|
|
|
|
|
|
|
sub _abstract { |
1619
|
1
|
|
|
1
|
|
4
|
shift; |
1620
|
1
|
|
|
|
|
5
|
$OPTS{abstract} = shift; |
1621
|
|
|
|
|
|
|
} |
1622
|
|
|
|
|
|
|
sub _with { |
1623
|
7
|
|
|
7
|
|
61
|
shift; |
1624
|
7
|
|
50
|
|
|
17
|
push @{ $OPTS{with}||=[] }, @_; |
|
7
|
|
|
|
|
72
|
|
1625
|
|
|
|
|
|
|
} |
1626
|
|
|
|
|
|
|
sub _toolkit { |
1627
|
0
|
|
|
0
|
|
0
|
shift; |
1628
|
0
|
|
|
|
|
0
|
my ($toolkit, @imports) = @_; |
1629
|
0
|
|
|
|
|
0
|
$OPTS{toolkit} = $toolkit; |
1630
|
0
|
0
|
0
|
|
|
0
|
push @{ $OPTS{import}||=[] }, @imports if @imports; |
|
0
|
|
|
|
|
0
|
|
1631
|
|
|
|
|
|
|
} |
1632
|
|
|
|
|
|
|
sub _requires { |
1633
|
3
|
|
|
3
|
|
18
|
shift; |
1634
|
3
|
|
100
|
|
|
7
|
push @{ $OPTS{requires}||=[] }, @_; |
|
3
|
|
|
|
|
30
|
|
1635
|
|
|
|
|
|
|
} |
1636
|
|
|
|
|
|
|
sub _coerce { |
1637
|
1
|
|
|
1
|
|
10
|
shift; |
1638
|
1
|
|
50
|
|
|
3
|
push @{ $OPTS{coerce}||=[] }, @_; |
|
1
|
|
|
|
|
7
|
|
1639
|
|
|
|
|
|
|
} |
1640
|
|
|
|
|
|
|
sub _factory { |
1641
|
2
|
|
|
2
|
|
27
|
shift; |
1642
|
2
|
|
100
|
|
|
4
|
push @{ $OPTS{factory}||=[] }, @_; |
|
2
|
|
|
|
|
12
|
|
1643
|
|
|
|
|
|
|
} |
1644
|
|
|
|
|
|
|
sub _constant { |
1645
|
10
|
|
|
10
|
|
76
|
shift; |
1646
|
10
|
|
|
|
|
30
|
my ($name, $value) = @_; |
1647
|
10
|
|
|
|
|
37
|
$OPTS{constant}{$name} = $value; |
1648
|
|
|
|
|
|
|
} |
1649
|
|
|
|
|
|
|
sub _can { |
1650
|
10
|
|
|
10
|
|
705
|
shift; |
1651
|
10
|
|
|
|
|
44
|
my ($name, $code) = @_; |
1652
|
10
|
|
|
|
|
52
|
$OPTS{can}{$name} = $code; |
1653
|
|
|
|
|
|
|
} |
1654
|
|
|
|
|
|
|
sub _multimethod { |
1655
|
0
|
|
|
0
|
|
0
|
shift; |
1656
|
0
|
|
|
|
|
0
|
my ($name, $spec) = @_; |
1657
|
0
|
|
0
|
|
|
0
|
push @{ $OPTS{multimethod} ||= [] }, $name => $spec; |
|
0
|
|
|
|
|
0
|
|
1658
|
|
|
|
|
|
|
} |
1659
|
|
|
|
|
|
|
sub _modifier { |
1660
|
3
|
|
|
3
|
|
39
|
shift; |
1661
|
3
|
|
|
|
|
10
|
my ($kind, $name, $value) = @_; |
1662
|
3
|
|
50
|
|
|
6
|
push @{ $OPTS{$kind} ||= [] }, $name, $value; |
|
3
|
|
|
|
|
23
|
|
1663
|
|
|
|
|
|
|
} |
1664
|
|
|
|
|
|
|
sub _include { |
1665
|
2
|
|
|
2
|
|
20
|
shift; |
1666
|
|
|
|
|
|
|
|
1667
|
2
|
|
|
|
|
655
|
require Path::ScanINC; |
1668
|
2
|
|
|
|
|
17218
|
my @chunks = split /::/, $_[0]; |
1669
|
2
|
|
|
|
|
6
|
$chunks[-1] .= '.pl'; |
1670
|
2
|
|
|
|
|
23
|
my $file = Path::ScanINC->new->first_file(@chunks); |
1671
|
|
|
|
|
|
|
|
1672
|
2
|
50
|
|
|
|
650
|
ref $file eq 'ARRAY' and die "not supported yet"; |
1673
|
2
|
|
|
|
|
53
|
my $code = $file->slurp_utf8; |
1674
|
|
|
|
|
|
|
|
1675
|
2
|
|
|
|
|
1574
|
sprintf( |
1676
|
|
|
|
|
|
|
"do {\n# line 1 %s\n%s\n};\n1;\n", |
1677
|
|
|
|
|
|
|
B::perlstring($file), |
1678
|
|
|
|
|
|
|
$code, |
1679
|
|
|
|
|
|
|
); |
1680
|
|
|
|
|
|
|
} |
1681
|
|
|
|
|
|
|
|
1682
|
|
|
|
|
|
|
#{ |
1683
|
|
|
|
|
|
|
# package MooX::Pression::Anonymous::Package; |
1684
|
|
|
|
|
|
|
# our $AUTHORITY = 'cpan:TOBYINK'; |
1685
|
|
|
|
|
|
|
# our $VERSION = '0.300'; |
1686
|
|
|
|
|
|
|
# use overload q[""] => sub { ${$_[0]} }, fallback => 1; |
1687
|
|
|
|
|
|
|
# sub DESTROY {} |
1688
|
|
|
|
|
|
|
# sub AUTOLOAD { |
1689
|
|
|
|
|
|
|
# my $me = shift; |
1690
|
|
|
|
|
|
|
# (my $method = our $AUTOLOAD) =~ s/.*:://; |
1691
|
|
|
|
|
|
|
# $$me->$method(@_); |
1692
|
|
|
|
|
|
|
# } |
1693
|
|
|
|
|
|
|
# |
1694
|
|
|
|
|
|
|
# package MooX::Pression::Anonymous::Class; |
1695
|
|
|
|
|
|
|
# our $AUTHORITY = 'cpan:TOBYINK'; |
1696
|
|
|
|
|
|
|
# our $VERSION = '0.300'; |
1697
|
|
|
|
|
|
|
# our @ISA = qw(MooX::Pression::Anonymous::Package); |
1698
|
|
|
|
|
|
|
# sub new { |
1699
|
|
|
|
|
|
|
# my $me = shift; |
1700
|
|
|
|
|
|
|
# $$me->new(@_); |
1701
|
|
|
|
|
|
|
# } |
1702
|
|
|
|
|
|
|
# use overload q[&{}] => sub { |
1703
|
|
|
|
|
|
|
# my $me = shift; |
1704
|
|
|
|
|
|
|
# sub { $me->new(@_) } |
1705
|
|
|
|
|
|
|
# }; |
1706
|
|
|
|
|
|
|
# |
1707
|
|
|
|
|
|
|
# package MooX::Pression::Anonymous::Role; |
1708
|
|
|
|
|
|
|
# our $AUTHORITY = 'cpan:TOBYINK'; |
1709
|
|
|
|
|
|
|
# our $VERSION = '0.300'; |
1710
|
|
|
|
|
|
|
# our @ISA = qw(MooX::Pression::Anonymous::Package); |
1711
|
|
|
|
|
|
|
# |
1712
|
|
|
|
|
|
|
# package MooX::Pression::Anonymous::ParameterizableClass; |
1713
|
|
|
|
|
|
|
# our $AUTHORITY = 'cpan:TOBYINK'; |
1714
|
|
|
|
|
|
|
# our $VERSION = '0.300'; |
1715
|
|
|
|
|
|
|
# our @ISA = qw(MooX::Pression::Anonymous::Package); |
1716
|
|
|
|
|
|
|
# sub generate_package { |
1717
|
|
|
|
|
|
|
# my $me = shift; |
1718
|
|
|
|
|
|
|
# my $gen = $$me->generate_package(@_); |
1719
|
|
|
|
|
|
|
# bless \$gen, 'MooX::Pression::Anonymous::Class'; |
1720
|
|
|
|
|
|
|
# } |
1721
|
|
|
|
|
|
|
# use overload q[&{}] => sub { |
1722
|
|
|
|
|
|
|
# my $me = shift; |
1723
|
|
|
|
|
|
|
# sub { $me->new_class(@_) } |
1724
|
|
|
|
|
|
|
# }; |
1725
|
|
|
|
|
|
|
# |
1726
|
|
|
|
|
|
|
# package MooX::Pression::Anonymous::ParameterizableRole; |
1727
|
|
|
|
|
|
|
# our $AUTHORITY = 'cpan:TOBYINK'; |
1728
|
|
|
|
|
|
|
# our $VERSION = '0.300'; |
1729
|
|
|
|
|
|
|
# our @ISA = qw(MooX::Pression::Anonymous::Package); |
1730
|
|
|
|
|
|
|
# sub generate_package { |
1731
|
|
|
|
|
|
|
# my $me = shift; |
1732
|
|
|
|
|
|
|
# my $gen = $$me->generate_package(@_); |
1733
|
|
|
|
|
|
|
# bless \$gen, 'MooX::Pression::Anonymous::Class'; |
1734
|
|
|
|
|
|
|
# } |
1735
|
|
|
|
|
|
|
# use overload q[&{}] => sub { |
1736
|
|
|
|
|
|
|
# my $me = shift; |
1737
|
|
|
|
|
|
|
# sub { $me->new_role(@_) } |
1738
|
|
|
|
|
|
|
# }; |
1739
|
|
|
|
|
|
|
#} |
1740
|
|
|
|
|
|
|
|
1741
|
|
|
|
|
|
|
my $i = 0; |
1742
|
|
|
|
|
|
|
sub anonymous_package { |
1743
|
4
|
|
|
4
|
0
|
44315
|
my $me = shift; |
1744
|
4
|
|
|
|
|
30
|
my ($kind, $callback, %opts) = @_; |
1745
|
4
|
|
|
|
|
18
|
my $package_dfn = $me->_package_callback($callback); |
1746
|
|
|
|
|
|
|
|
1747
|
4
|
|
|
|
|
12
|
for my $forbidden (qw/ factory type_name coerce /) { |
1748
|
12
|
50
|
|
|
|
32
|
die if exists $package_dfn->{$forbidden}; |
1749
|
|
|
|
|
|
|
} |
1750
|
4
|
|
|
|
|
11
|
$package_dfn->{type_name} = undef; |
1751
|
4
|
|
|
|
|
9
|
$package_dfn->{factory} = undef; |
1752
|
|
|
|
|
|
|
|
1753
|
4
|
|
|
|
|
21
|
my $qname = sprintf('%s::__ANON_%06d__', __PACKAGE__, ++$i); |
1754
|
|
|
|
|
|
|
|
1755
|
4
|
|
|
|
|
27
|
require MooX::Press; |
1756
|
4
|
|
|
|
|
11
|
my $method = "make_$kind"; |
1757
|
4
|
|
|
|
|
37
|
MooX::Press->$method("::$qname", %opts, %$package_dfn); |
1758
|
|
|
|
|
|
|
|
1759
|
4
|
|
|
|
|
22023
|
require Module::Runtime; |
1760
|
4
|
|
|
|
|
17
|
$INC{Module::Runtime::module_notional_filename($qname)} = __FILE__; |
1761
|
|
|
|
|
|
|
#return bless(\$qname, "MooX::Pression::Anonymous::".ucfirst($kind)); |
1762
|
4
|
|
|
|
|
120
|
return $qname; |
1763
|
|
|
|
|
|
|
} |
1764
|
|
|
|
|
|
|
|
1765
|
|
|
|
|
|
|
sub anonymous_generator { |
1766
|
1
|
|
|
1
|
0
|
23
|
my $me = shift; |
1767
|
1
|
|
|
|
|
9
|
my ($kind, $callback, %opts) = @_; |
1768
|
1
|
|
|
|
|
8
|
my $qname = sprintf('%s::__ANON_%06d__', __PACKAGE__, ++$i); |
1769
|
|
|
|
|
|
|
|
1770
|
1
|
|
|
|
|
5
|
require MooX::Press; |
1771
|
1
|
|
|
|
|
5
|
my $method = "make_$kind\_generator"; |
1772
|
1
|
|
|
|
|
8
|
MooX::Press->$method("::$qname", %opts, generator => $callback); |
1773
|
|
|
|
|
|
|
|
1774
|
1
|
|
|
|
|
598
|
require Module::Runtime; |
1775
|
1
|
|
|
|
|
10
|
$INC{Module::Runtime::module_notional_filename($qname)} = __FILE__; |
1776
|
|
|
|
|
|
|
#return bless(\$qname, "MooX::Pression::Anonymous::Parameterizable".ucfirst($kind)); |
1777
|
1
|
|
|
|
|
35
|
return $qname; |
1778
|
|
|
|
|
|
|
} |
1779
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
1; |
1781
|
|
|
|
|
|
|
|
1782
|
|
|
|
|
|
|
__END__ |
1783
|
|
|
|
|
|
|
|
1784
|
|
|
|
|
|
|
=pod |
1785
|
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
|
=encoding utf-8 |
1787
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
=head1 NAME |
1789
|
|
|
|
|
|
|
|
1790
|
|
|
|
|
|
|
MooX::Pression - express yourself through moo |
1791
|
|
|
|
|
|
|
|
1792
|
|
|
|
|
|
|
=head1 SYNOPSIS |
1793
|
|
|
|
|
|
|
|
1794
|
|
|
|
|
|
|
MyApp.pm |
1795
|
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
use v5.18; |
1797
|
|
|
|
|
|
|
use strict; |
1798
|
|
|
|
|
|
|
use warnings; |
1799
|
|
|
|
|
|
|
|
1800
|
|
|
|
|
|
|
package MyApp { |
1801
|
|
|
|
|
|
|
use MooX::Pression; |
1802
|
|
|
|
|
|
|
|
1803
|
|
|
|
|
|
|
class Person { |
1804
|
|
|
|
|
|
|
has name ( type => Str, required => true ); |
1805
|
|
|
|
|
|
|
has gender ( type => Str ); |
1806
|
|
|
|
|
|
|
|
1807
|
|
|
|
|
|
|
factory new_man (Str $name) { |
1808
|
|
|
|
|
|
|
return $class->new(name => $name, gender => 'male'); |
1809
|
|
|
|
|
|
|
} |
1810
|
|
|
|
|
|
|
|
1811
|
|
|
|
|
|
|
factory new_woman (Str $name) { |
1812
|
|
|
|
|
|
|
return $class->new(name => $name, gender => 'female'); |
1813
|
|
|
|
|
|
|
} |
1814
|
|
|
|
|
|
|
|
1815
|
|
|
|
|
|
|
method greet (Person *friend, Str *greeting = "Hello") { |
1816
|
|
|
|
|
|
|
printf("%s, %s!\n", $arg->greeting, $arg->friend->name); |
1817
|
|
|
|
|
|
|
} |
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
coerce from Str via from_string { |
1820
|
|
|
|
|
|
|
return $class->new(name => $_); |
1821
|
|
|
|
|
|
|
} |
1822
|
|
|
|
|
|
|
} |
1823
|
|
|
|
|
|
|
} |
1824
|
|
|
|
|
|
|
|
1825
|
|
|
|
|
|
|
my_script.pl |
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
use v5.18; |
1828
|
|
|
|
|
|
|
use strict; |
1829
|
|
|
|
|
|
|
use warnings; |
1830
|
|
|
|
|
|
|
use MyApp; |
1831
|
|
|
|
|
|
|
use MyApp::Types qw( is_Person ); |
1832
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
# Create a new MyApp::Person object. |
1834
|
|
|
|
|
|
|
# |
1835
|
|
|
|
|
|
|
my $alice = MyApp->new_woman("Alice"); |
1836
|
|
|
|
|
|
|
is_Person($alice) or die; |
1837
|
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
|
# The string "Bob" will be coerced to a MyApp::Person. |
1839
|
|
|
|
|
|
|
# |
1840
|
|
|
|
|
|
|
$alice->greet(friend => "Bob", greeting => 'Hi'); |
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
=head1 DESCRIPTION |
1843
|
|
|
|
|
|
|
|
1844
|
|
|
|
|
|
|
L<MooX::Pression> is kind of like L<Moops>; a marrying together of L<Moo> |
1845
|
|
|
|
|
|
|
with L<Type::Tiny> and some keyword declaration magic. Instead of being |
1846
|
|
|
|
|
|
|
built on L<Kavorka>, L<Parse::Keyword>, L<Keyword::Simple> and a whole |
1847
|
|
|
|
|
|
|
heap of crack, it is built on L<MooX::Press>, L<Keyword::Simple>, and L<PPR>. |
1848
|
|
|
|
|
|
|
I'm not saying there isn't some crazy stuff going on under the hood, but |
1849
|
|
|
|
|
|
|
it ought to be a little more maintainable. |
1850
|
|
|
|
|
|
|
|
1851
|
|
|
|
|
|
|
Some of the insane features of Moops have been dialled back, and others |
1852
|
|
|
|
|
|
|
have been amped up. |
1853
|
|
|
|
|
|
|
|
1854
|
|
|
|
|
|
|
It's more opinionated about API design and usage than Moops is, but in |
1855
|
|
|
|
|
|
|
most cases, it should be fairly easy to port Moops code to MooX::Pression. |
1856
|
|
|
|
|
|
|
|
1857
|
|
|
|
|
|
|
MooX::Pression requires Perl 5.18.0 or above. It may work on Perl 5.14.x |
1858
|
|
|
|
|
|
|
and Perl 5.16.x partly, but there are likely to be issues. |
1859
|
|
|
|
|
|
|
|
1860
|
|
|
|
|
|
|
L<MooX::Press> is a less magic version of MooX::Pression and only requires |
1861
|
|
|
|
|
|
|
Perl 5.8.8 or above. |
1862
|
|
|
|
|
|
|
|
1863
|
|
|
|
|
|
|
=head2 Important Concepts |
1864
|
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
=head3 The Factory Package and Prefix |
1866
|
|
|
|
|
|
|
|
1867
|
|
|
|
|
|
|
MooX::Pression assumes that all the classes and roles you are building |
1868
|
|
|
|
|
|
|
with it will be defined under the same namespace B<prefix>. For example |
1869
|
|
|
|
|
|
|
"MyApp::Person" and "MyApp::Company" are both defined under the common |
1870
|
|
|
|
|
|
|
prefix of "MyApp". |
1871
|
|
|
|
|
|
|
|
1872
|
|
|
|
|
|
|
It also assumes there will be a B<< factory package >> that can be used |
1873
|
|
|
|
|
|
|
to build new instances of your class. Rather than creating a new person |
1874
|
|
|
|
|
|
|
object with C<< MyApp::Person->new() >>, you should create a new person |
1875
|
|
|
|
|
|
|
object with C<< MyApp->new_person() >>. Calling C<< MyApp::Person->new() >> |
1876
|
|
|
|
|
|
|
directly is only encouraged from within the "MyApp::Person" class itself, |
1877
|
|
|
|
|
|
|
and from within the factory. Everywhere else, you should call |
1878
|
|
|
|
|
|
|
C<< MyApp->new_person() >> instead. |
1879
|
|
|
|
|
|
|
|
1880
|
|
|
|
|
|
|
By default, the factory package and the prefix are the same: they are |
1881
|
|
|
|
|
|
|
the caller that you imported MooX::Pression into. But they can be set |
1882
|
|
|
|
|
|
|
to whatever: |
1883
|
|
|
|
|
|
|
|
1884
|
|
|
|
|
|
|
use MooX::Pression ( |
1885
|
|
|
|
|
|
|
prefix => 'MyApp::Objects', |
1886
|
|
|
|
|
|
|
factory_package => 'MyApp::Makers', |
1887
|
|
|
|
|
|
|
); |
1888
|
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
|
MooX::Pression assumes that you are defining all the classes and roles |
1890
|
|
|
|
|
|
|
within this namespace prefix in a single Perl module file. This Perl |
1891
|
|
|
|
|
|
|
module file would normally be named based on the prefix, so in the |
1892
|
|
|
|
|
|
|
example above, it would be "MyApp/Objects.pm" and in the example from |
1893
|
|
|
|
|
|
|
the SYNOPSIS, it would be "MyApp.pm". |
1894
|
|
|
|
|
|
|
|
1895
|
|
|
|
|
|
|
But see also the documentation for C<include>. |
1896
|
|
|
|
|
|
|
|
1897
|
|
|
|
|
|
|
Of course, there is nothing to stop you from having multiple prefixes |
1898
|
|
|
|
|
|
|
for different logical parts of a larger codebase, but MooX::Pression |
1899
|
|
|
|
|
|
|
assumes that if it's been set up for a prefix, it owns that prefix and |
1900
|
|
|
|
|
|
|
everything under it, and it's all defined in the same Perl module. |
1901
|
|
|
|
|
|
|
|
1902
|
|
|
|
|
|
|
Each object defined by MooX::Pression will have a C<FACTORY> method, |
1903
|
|
|
|
|
|
|
so you can do: |
1904
|
|
|
|
|
|
|
|
1905
|
|
|
|
|
|
|
$person_object->FACTORY |
1906
|
|
|
|
|
|
|
|
1907
|
|
|
|
|
|
|
And it will return the string "MyApp". This allows for stuff like: |
1908
|
|
|
|
|
|
|
|
1909
|
|
|
|
|
|
|
class Person { |
1910
|
|
|
|
|
|
|
method give_birth { |
1911
|
|
|
|
|
|
|
return $self->FACTORY->new_person(); |
1912
|
|
|
|
|
|
|
} |
1913
|
|
|
|
|
|
|
} |
1914
|
|
|
|
|
|
|
|
1915
|
|
|
|
|
|
|
=head3 The Type Library |
1916
|
|
|
|
|
|
|
|
1917
|
|
|
|
|
|
|
While building your classes and objects, MooX::Pression will also build |
1918
|
|
|
|
|
|
|
type constraints for each of them. So for the "MyApp::Person" class |
1919
|
|
|
|
|
|
|
above, it also builds a B<Person> type constraint. This can be used |
1920
|
|
|
|
|
|
|
in Moo/Moose attribute definitions like: |
1921
|
|
|
|
|
|
|
|
1922
|
|
|
|
|
|
|
use MyApp; |
1923
|
|
|
|
|
|
|
use MyApp::Types qw( Person ); |
1924
|
|
|
|
|
|
|
|
1925
|
|
|
|
|
|
|
use Moose; |
1926
|
|
|
|
|
|
|
has boss => (is => 'rw', isa => Person); |
1927
|
|
|
|
|
|
|
|
1928
|
|
|
|
|
|
|
And just anywhere a type constraint may be used generally. You should |
1929
|
|
|
|
|
|
|
know this stuff by now. |
1930
|
|
|
|
|
|
|
|
1931
|
|
|
|
|
|
|
Note that we had to C<use MyApp> before we could C<use MyApp::Types>. |
1932
|
|
|
|
|
|
|
This is because there isn't a physical "MyApp/Types.pm" file on disk; |
1933
|
|
|
|
|
|
|
it is defined entirely by "MyApp.pm". |
1934
|
|
|
|
|
|
|
|
1935
|
|
|
|
|
|
|
Your type library will be the same as your namespace prefix, with |
1936
|
|
|
|
|
|
|
"::Types" added at the end. But you can change that: |
1937
|
|
|
|
|
|
|
|
1938
|
|
|
|
|
|
|
use MooX::Pression ( |
1939
|
|
|
|
|
|
|
prefix => 'MyApp::Objects', |
1940
|
|
|
|
|
|
|
factory_package => 'MyApp::Makers', |
1941
|
|
|
|
|
|
|
type_library => 'MyApp::TypeLibrary', |
1942
|
|
|
|
|
|
|
); |
1943
|
|
|
|
|
|
|
|
1944
|
|
|
|
|
|
|
It can sometimes be helpful to pre-warn MooX::Pression about the |
1945
|
|
|
|
|
|
|
types you're going to define before you define them, just so it |
1946
|
|
|
|
|
|
|
is able to allow them as barewords in some places... |
1947
|
|
|
|
|
|
|
|
1948
|
|
|
|
|
|
|
use MooX::Pression ( |
1949
|
|
|
|
|
|
|
prefix => 'MyApp::Objects', |
1950
|
|
|
|
|
|
|
factory_package => 'MyApp::Makers', |
1951
|
|
|
|
|
|
|
type_library => 'MyApp::TypeLibrary', |
1952
|
|
|
|
|
|
|
declare => [qw( Person Company )], |
1953
|
|
|
|
|
|
|
); |
1954
|
|
|
|
|
|
|
|
1955
|
|
|
|
|
|
|
See also L<Type::Tiny::Manual>. |
1956
|
|
|
|
|
|
|
|
1957
|
|
|
|
|
|
|
=head2 Keywords |
1958
|
|
|
|
|
|
|
|
1959
|
|
|
|
|
|
|
=head3 C<< class >> |
1960
|
|
|
|
|
|
|
|
1961
|
|
|
|
|
|
|
Define a very basic class: |
1962
|
|
|
|
|
|
|
|
1963
|
|
|
|
|
|
|
class Person; |
1964
|
|
|
|
|
|
|
|
1965
|
|
|
|
|
|
|
Define a more complicated class: |
1966
|
|
|
|
|
|
|
|
1967
|
|
|
|
|
|
|
class Person { |
1968
|
|
|
|
|
|
|
...; |
1969
|
|
|
|
|
|
|
} |
1970
|
|
|
|
|
|
|
|
1971
|
|
|
|
|
|
|
Note that for the C<class> keyword without a block, it does I<not> act like |
1972
|
|
|
|
|
|
|
the C<package> keyword by changing the "ambient" package. It just defines a |
1973
|
|
|
|
|
|
|
totally empty class with no methods or attributes. |
1974
|
|
|
|
|
|
|
|
1975
|
|
|
|
|
|
|
The prefix will automatically be added to the class name, so if the prefix |
1976
|
|
|
|
|
|
|
is MyApp, the above will create a class called MyApp::Person. It will also |
1977
|
|
|
|
|
|
|
create a factory method C<< MyApp->new_person >>. (The name is generated by |
1978
|
|
|
|
|
|
|
stripping the prefix from the class name, replacing any "::" with an |
1979
|
|
|
|
|
|
|
underscore, lowercasing, and prefixing it with "new_".) And it will create |
1980
|
|
|
|
|
|
|
a type called B<Person> in the type library. (Same rules to generate the |
1981
|
|
|
|
|
|
|
name apart from lowercasing and adding "new_".) |
1982
|
|
|
|
|
|
|
|
1983
|
|
|
|
|
|
|
Classes can be given more complex names: |
1984
|
|
|
|
|
|
|
|
1985
|
|
|
|
|
|
|
class Person::Neanderthal { |
1986
|
|
|
|
|
|
|
...; |
1987
|
|
|
|
|
|
|
} |
1988
|
|
|
|
|
|
|
|
1989
|
|
|
|
|
|
|
Will create "MyApp::Person::Neanderthal" class, a factory method called |
1990
|
|
|
|
|
|
|
C<< MyApp->new_person_neanderthal >>, and a B<Person_Neanderthal> type. |
1991
|
|
|
|
|
|
|
|
1992
|
|
|
|
|
|
|
It is possible to create a class without the prefix: |
1993
|
|
|
|
|
|
|
|
1994
|
|
|
|
|
|
|
class ::Person { |
1995
|
|
|
|
|
|
|
...; |
1996
|
|
|
|
|
|
|
} |
1997
|
|
|
|
|
|
|
|
1998
|
|
|
|
|
|
|
The class name will now be "Person" instead of "MyApp::Person"! |
1999
|
|
|
|
|
|
|
|
2000
|
|
|
|
|
|
|
=head4 Nested classes |
2001
|
|
|
|
|
|
|
|
2002
|
|
|
|
|
|
|
C<class> blocks can be nested. This establishes an inheritance heirarchy. |
2003
|
|
|
|
|
|
|
|
2004
|
|
|
|
|
|
|
class Animal { |
2005
|
|
|
|
|
|
|
has name; |
2006
|
|
|
|
|
|
|
class Mammal { |
2007
|
|
|
|
|
|
|
class Primate { |
2008
|
|
|
|
|
|
|
class Monkey; |
2009
|
|
|
|
|
|
|
class Gorilla; |
2010
|
|
|
|
|
|
|
class Human { |
2011
|
|
|
|
|
|
|
class Superhuman; |
2012
|
|
|
|
|
|
|
} |
2013
|
|
|
|
|
|
|
} |
2014
|
|
|
|
|
|
|
} |
2015
|
|
|
|
|
|
|
class Bird; |
2016
|
|
|
|
|
|
|
class Fish { |
2017
|
|
|
|
|
|
|
class Shark; |
2018
|
|
|
|
|
|
|
} |
2019
|
|
|
|
|
|
|
} |
2020
|
|
|
|
|
|
|
|
2021
|
|
|
|
|
|
|
my $superman = MyApp->new_superhuman( name => 'Kal El' ); |
2022
|
|
|
|
|
|
|
|
2023
|
|
|
|
|
|
|
See also C<extends> as an alternative way of declaring inheritance. |
2024
|
|
|
|
|
|
|
|
2025
|
|
|
|
|
|
|
It is possible to prefix a class name with a plus sign: |
2026
|
|
|
|
|
|
|
|
2027
|
|
|
|
|
|
|
package MyApp { |
2028
|
|
|
|
|
|
|
use MooX::Pression; |
2029
|
|
|
|
|
|
|
class Person { |
2030
|
|
|
|
|
|
|
has name; |
2031
|
|
|
|
|
|
|
class +Employee { |
2032
|
|
|
|
|
|
|
has job_title; |
2033
|
|
|
|
|
|
|
} |
2034
|
|
|
|
|
|
|
} |
2035
|
|
|
|
|
|
|
} |
2036
|
|
|
|
|
|
|
|
2037
|
|
|
|
|
|
|
Now the employee class will be named C<MyApp::Person::Employee> instead of |
2038
|
|
|
|
|
|
|
the usual C<MyApp::Employee>. |
2039
|
|
|
|
|
|
|
|
2040
|
|
|
|
|
|
|
Classes can be declared as abstract: |
2041
|
|
|
|
|
|
|
|
2042
|
|
|
|
|
|
|
package MyApp { |
2043
|
|
|
|
|
|
|
use MooX::Pression; |
2044
|
|
|
|
|
|
|
abstract class Animal { |
2045
|
|
|
|
|
|
|
class Cat; |
2046
|
|
|
|
|
|
|
class Dog; |
2047
|
|
|
|
|
|
|
} |
2048
|
|
|
|
|
|
|
} |
2049
|
|
|
|
|
|
|
|
2050
|
|
|
|
|
|
|
For abstract classes, there is no constructor or factory, so you cannot create |
2051
|
|
|
|
|
|
|
an Animal instance directly; but you can create instances of the subclasses. |
2052
|
|
|
|
|
|
|
It is usually better to use roles than abstract classes, but sometimes the |
2053
|
|
|
|
|
|
|
abstract class makes more intuitive sense. |
2054
|
|
|
|
|
|
|
|
2055
|
|
|
|
|
|
|
=head3 C<< role >> |
2056
|
|
|
|
|
|
|
|
2057
|
|
|
|
|
|
|
Define a very basic role: |
2058
|
|
|
|
|
|
|
|
2059
|
|
|
|
|
|
|
role Person; |
2060
|
|
|
|
|
|
|
|
2061
|
|
|
|
|
|
|
Define a more complicated role: |
2062
|
|
|
|
|
|
|
|
2063
|
|
|
|
|
|
|
role Person { |
2064
|
|
|
|
|
|
|
...; |
2065
|
|
|
|
|
|
|
} |
2066
|
|
|
|
|
|
|
|
2067
|
|
|
|
|
|
|
This is just the same as C<class> but defines a role instead of a class. |
2068
|
|
|
|
|
|
|
|
2069
|
|
|
|
|
|
|
Roles cannot be nested within each other, nor can roles be nested in classes, |
2070
|
|
|
|
|
|
|
nor classes in roles. |
2071
|
|
|
|
|
|
|
|
2072
|
|
|
|
|
|
|
=head3 C<< interface >> |
2073
|
|
|
|
|
|
|
|
2074
|
|
|
|
|
|
|
An interface is a lightweight role. It cannot define attributes, methods, |
2075
|
|
|
|
|
|
|
multimethods, or method modifiers, but otherwise functions as a role. |
2076
|
|
|
|
|
|
|
(It may have C<requires> statements and define constants.) |
2077
|
|
|
|
|
|
|
|
2078
|
|
|
|
|
|
|
package MyApp; |
2079
|
|
|
|
|
|
|
use MooX::Pression; |
2080
|
|
|
|
|
|
|
|
2081
|
|
|
|
|
|
|
interface Serializer { |
2082
|
|
|
|
|
|
|
requires serialize; |
2083
|
|
|
|
|
|
|
} |
2084
|
|
|
|
|
|
|
|
2085
|
|
|
|
|
|
|
interface Deserializer { |
2086
|
|
|
|
|
|
|
requires deserialize; |
2087
|
|
|
|
|
|
|
} |
2088
|
|
|
|
|
|
|
|
2089
|
|
|
|
|
|
|
class MyJSON { |
2090
|
|
|
|
|
|
|
with Serializer, Deserialize; |
2091
|
|
|
|
|
|
|
method serialize ($value) { ... } |
2092
|
|
|
|
|
|
|
method deserialize ($value) { ... } |
2093
|
|
|
|
|
|
|
} |
2094
|
|
|
|
|
|
|
|
2095
|
|
|
|
|
|
|
my $obj = MyApp->new_myjson; |
2096
|
|
|
|
|
|
|
$obj->does('MyApp::Serializer'); # true |
2097
|
|
|
|
|
|
|
|
2098
|
|
|
|
|
|
|
=head3 C<< toolkit >> |
2099
|
|
|
|
|
|
|
|
2100
|
|
|
|
|
|
|
Use a different toolkit instead of Moo. |
2101
|
|
|
|
|
|
|
|
2102
|
|
|
|
|
|
|
# use Mouse |
2103
|
|
|
|
|
|
|
class Foo { |
2104
|
|
|
|
|
|
|
toolkit Mouse; |
2105
|
|
|
|
|
|
|
} |
2106
|
|
|
|
|
|
|
|
2107
|
|
|
|
|
|
|
# use Moose |
2108
|
|
|
|
|
|
|
# use MooseX::Aliases |
2109
|
|
|
|
|
|
|
# use MooseX::StrictConstructor |
2110
|
|
|
|
|
|
|
class Bar { |
2111
|
|
|
|
|
|
|
toolkit Moose ( Aliases, StrictConstructor ); |
2112
|
|
|
|
|
|
|
} |
2113
|
|
|
|
|
|
|
|
2114
|
|
|
|
|
|
|
You can of course specify you want to use Moo: |
2115
|
|
|
|
|
|
|
|
2116
|
|
|
|
|
|
|
class Baz { |
2117
|
|
|
|
|
|
|
toolkit Moo; |
2118
|
|
|
|
|
|
|
} |
2119
|
|
|
|
|
|
|
|
2120
|
|
|
|
|
|
|
Not all MooseX/MouseX/MooX packages will work, but *X::StrictConstructor will. |
2121
|
|
|
|
|
|
|
|
2122
|
|
|
|
|
|
|
It is possible to set a default toolkit when you import MooX::Pression. |
2123
|
|
|
|
|
|
|
|
2124
|
|
|
|
|
|
|
use MooX::Pression ( |
2125
|
|
|
|
|
|
|
..., |
2126
|
|
|
|
|
|
|
toolkit => 'Moose', |
2127
|
|
|
|
|
|
|
); |
2128
|
|
|
|
|
|
|
|
2129
|
|
|
|
|
|
|
use MooX::Pression ( |
2130
|
|
|
|
|
|
|
..., |
2131
|
|
|
|
|
|
|
toolkit => 'Mouse', |
2132
|
|
|
|
|
|
|
); |
2133
|
|
|
|
|
|
|
|
2134
|
|
|
|
|
|
|
=head3 C<< extends >> |
2135
|
|
|
|
|
|
|
|
2136
|
|
|
|
|
|
|
Defines a parent class. Only for use within C<class> blocks. |
2137
|
|
|
|
|
|
|
|
2138
|
|
|
|
|
|
|
class Person { |
2139
|
|
|
|
|
|
|
extends Animal; |
2140
|
|
|
|
|
|
|
} |
2141
|
|
|
|
|
|
|
|
2142
|
|
|
|
|
|
|
This works: |
2143
|
|
|
|
|
|
|
|
2144
|
|
|
|
|
|
|
class Person { |
2145
|
|
|
|
|
|
|
extends ::Animal; # no prefix |
2146
|
|
|
|
|
|
|
} |
2147
|
|
|
|
|
|
|
|
2148
|
|
|
|
|
|
|
=head3 C<< with >> |
2149
|
|
|
|
|
|
|
|
2150
|
|
|
|
|
|
|
Composes roles. |
2151
|
|
|
|
|
|
|
|
2152
|
|
|
|
|
|
|
class Person { |
2153
|
|
|
|
|
|
|
with Employable, Consumer; |
2154
|
|
|
|
|
|
|
} |
2155
|
|
|
|
|
|
|
|
2156
|
|
|
|
|
|
|
role Consumer; |
2157
|
|
|
|
|
|
|
|
2158
|
|
|
|
|
|
|
role Worker; |
2159
|
|
|
|
|
|
|
|
2160
|
|
|
|
|
|
|
role Payable; |
2161
|
|
|
|
|
|
|
|
2162
|
|
|
|
|
|
|
role Employable { |
2163
|
|
|
|
|
|
|
with Worker, Payable; |
2164
|
|
|
|
|
|
|
} |
2165
|
|
|
|
|
|
|
|
2166
|
|
|
|
|
|
|
Because roles are processed before classes, you can compose roles into classes |
2167
|
|
|
|
|
|
|
where the role is defined later in the file. But if you compose one role into |
2168
|
|
|
|
|
|
|
another, you must define them in a sensible order. |
2169
|
|
|
|
|
|
|
|
2170
|
|
|
|
|
|
|
It is possible to compose a role that does not exist by adding a question mark |
2171
|
|
|
|
|
|
|
to the end of it: |
2172
|
|
|
|
|
|
|
|
2173
|
|
|
|
|
|
|
class Person { |
2174
|
|
|
|
|
|
|
with Employable, Consumer?; |
2175
|
|
|
|
|
|
|
} |
2176
|
|
|
|
|
|
|
|
2177
|
|
|
|
|
|
|
role Employable { |
2178
|
|
|
|
|
|
|
with Worker?, Payable?; |
2179
|
|
|
|
|
|
|
} |
2180
|
|
|
|
|
|
|
|
2181
|
|
|
|
|
|
|
This is equivalent to declaring an empty role. |
2182
|
|
|
|
|
|
|
|
2183
|
|
|
|
|
|
|
=head3 C<< begin >> |
2184
|
|
|
|
|
|
|
|
2185
|
|
|
|
|
|
|
This code gets run early on in the definition of a class or role. |
2186
|
|
|
|
|
|
|
|
2187
|
|
|
|
|
|
|
class Person { |
2188
|
|
|
|
|
|
|
begin { |
2189
|
|
|
|
|
|
|
say "Defining $package"; |
2190
|
|
|
|
|
|
|
} |
2191
|
|
|
|
|
|
|
} |
2192
|
|
|
|
|
|
|
|
2193
|
|
|
|
|
|
|
At the time the code gets run, none of the class's attributes or methods will |
2194
|
|
|
|
|
|
|
be defined yet. |
2195
|
|
|
|
|
|
|
|
2196
|
|
|
|
|
|
|
The lexical variables C<< $package >> and C<< $kind >> are defined within the |
2197
|
|
|
|
|
|
|
block. C<< $kind >> will be either 'class' or 'role'. |
2198
|
|
|
|
|
|
|
|
2199
|
|
|
|
|
|
|
It is possible to define a global chunk of code to run too: |
2200
|
|
|
|
|
|
|
|
2201
|
|
|
|
|
|
|
use MooX::Pression ( |
2202
|
|
|
|
|
|
|
..., |
2203
|
|
|
|
|
|
|
begin => sub { |
2204
|
|
|
|
|
|
|
my ($package, $kind) = @_; |
2205
|
|
|
|
|
|
|
...; |
2206
|
|
|
|
|
|
|
}, |
2207
|
|
|
|
|
|
|
); |
2208
|
|
|
|
|
|
|
|
2209
|
|
|
|
|
|
|
Per-package C<begin> overrides the global C<begin>. |
2210
|
|
|
|
|
|
|
|
2211
|
|
|
|
|
|
|
Unlike Perl's C<BEGIN> keyword, a package can only have one C<begin>. |
2212
|
|
|
|
|
|
|
|
2213
|
|
|
|
|
|
|
If C<class> definitions are nested, C<begin> blocks will be inherited by |
2214
|
|
|
|
|
|
|
child classes. If a parent class is specified via C<extends>, C<begin> |
2215
|
|
|
|
|
|
|
blocks will not be inherited. |
2216
|
|
|
|
|
|
|
|
2217
|
|
|
|
|
|
|
=head3 C<< end >> |
2218
|
|
|
|
|
|
|
|
2219
|
|
|
|
|
|
|
This code gets run late in the definition of a class or role. |
2220
|
|
|
|
|
|
|
|
2221
|
|
|
|
|
|
|
class Person { |
2222
|
|
|
|
|
|
|
end { |
2223
|
|
|
|
|
|
|
say "Finished defining $package"; |
2224
|
|
|
|
|
|
|
} |
2225
|
|
|
|
|
|
|
} |
2226
|
|
|
|
|
|
|
|
2227
|
|
|
|
|
|
|
The lexical variables C<< $package >> and C<< $kind >> are defined within the |
2228
|
|
|
|
|
|
|
block. C<< $kind >> will be either 'class' or 'role'. |
2229
|
|
|
|
|
|
|
|
2230
|
|
|
|
|
|
|
It is possible to define a global chunk of code to run too: |
2231
|
|
|
|
|
|
|
|
2232
|
|
|
|
|
|
|
use MooX::Pression ( |
2233
|
|
|
|
|
|
|
..., |
2234
|
|
|
|
|
|
|
end => sub { |
2235
|
|
|
|
|
|
|
my ($package, $kind) = @_; |
2236
|
|
|
|
|
|
|
...; |
2237
|
|
|
|
|
|
|
}, |
2238
|
|
|
|
|
|
|
); |
2239
|
|
|
|
|
|
|
|
2240
|
|
|
|
|
|
|
Per-package C<end> overrides the global C<end>. |
2241
|
|
|
|
|
|
|
|
2242
|
|
|
|
|
|
|
Unlike Perl's C<END> keyword, a package can only have one C<end>. |
2243
|
|
|
|
|
|
|
|
2244
|
|
|
|
|
|
|
If C<class> definitions are nested, C<end> blocks will be inherited by |
2245
|
|
|
|
|
|
|
child classes. If a parent class is specified via C<extends>, C<end> |
2246
|
|
|
|
|
|
|
blocks will not be inherited. |
2247
|
|
|
|
|
|
|
|
2248
|
|
|
|
|
|
|
=head3 C<< has >> |
2249
|
|
|
|
|
|
|
|
2250
|
|
|
|
|
|
|
class Person { |
2251
|
|
|
|
|
|
|
has name; |
2252
|
|
|
|
|
|
|
has age; |
2253
|
|
|
|
|
|
|
} |
2254
|
|
|
|
|
|
|
|
2255
|
|
|
|
|
|
|
my $bob = MyApp->new_person(name => "Bob", age => 21); |
2256
|
|
|
|
|
|
|
|
2257
|
|
|
|
|
|
|
Moo-style attribute specifications may be given: |
2258
|
|
|
|
|
|
|
|
2259
|
|
|
|
|
|
|
class Person { |
2260
|
|
|
|
|
|
|
has name ( is => rw, type => Str, required => true ); |
2261
|
|
|
|
|
|
|
has age ( is => rw, type => Int ); |
2262
|
|
|
|
|
|
|
} |
2263
|
|
|
|
|
|
|
|
2264
|
|
|
|
|
|
|
Note there is no fat comma after the attribute name! It is a bareword. |
2265
|
|
|
|
|
|
|
|
2266
|
|
|
|
|
|
|
Use a plus sign before an attribute name to modify an attribute defined |
2267
|
|
|
|
|
|
|
in a parent class. |
2268
|
|
|
|
|
|
|
|
2269
|
|
|
|
|
|
|
class Animal { |
2270
|
|
|
|
|
|
|
has name ( type => Str, required => false ); |
2271
|
|
|
|
|
|
|
|
2272
|
|
|
|
|
|
|
class Person { |
2273
|
|
|
|
|
|
|
has +name ( required => true ); |
2274
|
|
|
|
|
|
|
} |
2275
|
|
|
|
|
|
|
} |
2276
|
|
|
|
|
|
|
|
2277
|
|
|
|
|
|
|
C<rw>, C<rwp>, C<ro>, C<lazy>, C<true>, and C<false> are allowed as |
2278
|
|
|
|
|
|
|
barewords for readability, but C<is> is optional, and defaults to C<rw>. |
2279
|
|
|
|
|
|
|
|
2280
|
|
|
|
|
|
|
Note C<type> instead of C<isa>. Any type constraints from L<Types::Standard>, |
2281
|
|
|
|
|
|
|
L<Types::Common::Numeric>, and L<Types::Common::String> will be avaiable as |
2282
|
|
|
|
|
|
|
barewords. Also, any pre-declared types can be used as barewords. It's |
2283
|
|
|
|
|
|
|
possible to quote types as strings, in which case you don't need to have |
2284
|
|
|
|
|
|
|
pre-declared them. |
2285
|
|
|
|
|
|
|
|
2286
|
|
|
|
|
|
|
class Person { |
2287
|
|
|
|
|
|
|
has name ( type => Str, required => true ); |
2288
|
|
|
|
|
|
|
has age ( type => Int ); |
2289
|
|
|
|
|
|
|
has spouse ( type => 'Person' ); |
2290
|
|
|
|
|
|
|
has kids ( |
2291
|
|
|
|
|
|
|
is => lazy, |
2292
|
|
|
|
|
|
|
type => 'ArrayRef[Person]', |
2293
|
|
|
|
|
|
|
builder => sub { [] }, |
2294
|
|
|
|
|
|
|
); |
2295
|
|
|
|
|
|
|
} |
2296
|
|
|
|
|
|
|
|
2297
|
|
|
|
|
|
|
Note that when C<type> is a string, MooX::Pression will consult your |
2298
|
|
|
|
|
|
|
type library to figure out what it means. |
2299
|
|
|
|
|
|
|
|
2300
|
|
|
|
|
|
|
It is also possible to use C<< isa => 'SomeClass' >> or |
2301
|
|
|
|
|
|
|
C<< does => 'SomeRole' >> to force strings to be treated as class names |
2302
|
|
|
|
|
|
|
or role names instead of type names. |
2303
|
|
|
|
|
|
|
|
2304
|
|
|
|
|
|
|
class Person { |
2305
|
|
|
|
|
|
|
has name ( type => Str, required => true ); |
2306
|
|
|
|
|
|
|
has age ( type => Int ); |
2307
|
|
|
|
|
|
|
has spouse ( isa => 'Person' ); |
2308
|
|
|
|
|
|
|
has pet ( isa => '::Animal' ); # no prefix |
2309
|
|
|
|
|
|
|
} |
2310
|
|
|
|
|
|
|
|
2311
|
|
|
|
|
|
|
For enumerations, you can define them like this: |
2312
|
|
|
|
|
|
|
|
2313
|
|
|
|
|
|
|
class Person { |
2314
|
|
|
|
|
|
|
...; |
2315
|
|
|
|
|
|
|
has status ( enum => ['alive', 'dead', 'undead'] ); |
2316
|
|
|
|
|
|
|
} |
2317
|
|
|
|
|
|
|
|
2318
|
|
|
|
|
|
|
MooX::Pression integrates support for L<MooX::Enumeration> (and |
2319
|
|
|
|
|
|
|
L<MooseX::Enumeration>, but MouseX::Enumeration doesn't exist). |
2320
|
|
|
|
|
|
|
|
2321
|
|
|
|
|
|
|
class Person { |
2322
|
|
|
|
|
|
|
...; |
2323
|
|
|
|
|
|
|
has status ( |
2324
|
|
|
|
|
|
|
enum => ['alive', 'dead', 'undead'], |
2325
|
|
|
|
|
|
|
default => 'alive', |
2326
|
|
|
|
|
|
|
handles => 1, |
2327
|
|
|
|
|
|
|
); |
2328
|
|
|
|
|
|
|
} |
2329
|
|
|
|
|
|
|
|
2330
|
|
|
|
|
|
|
my $bob = MyApp->new_person; |
2331
|
|
|
|
|
|
|
if ( $bob->is_alive ) { |
2332
|
|
|
|
|
|
|
...; |
2333
|
|
|
|
|
|
|
} |
2334
|
|
|
|
|
|
|
|
2335
|
|
|
|
|
|
|
C<< handles => 1 >> creates methods named C<is_alive>, C<is_dead>, and |
2336
|
|
|
|
|
|
|
C<is_undead>, and C<< handles => 2 >> creates methods named |
2337
|
|
|
|
|
|
|
C<status_is_alive>, C<status_is_dead>, and C<status_is_undead>. |
2338
|
|
|
|
|
|
|
|
2339
|
|
|
|
|
|
|
Checking C<< $bob->status eq 'alvie' >> is prone to typos, but |
2340
|
|
|
|
|
|
|
C<< $bob->status_is_alvie >> will cause a runtime error because the |
2341
|
|
|
|
|
|
|
method is not defined. |
2342
|
|
|
|
|
|
|
|
2343
|
|
|
|
|
|
|
MooX::Pression also integrates support for L<Sub::HandlesVia> allowing |
2344
|
|
|
|
|
|
|
you to delegate certain methods to unblessed references and non-reference |
2345
|
|
|
|
|
|
|
values. For example: |
2346
|
|
|
|
|
|
|
|
2347
|
|
|
|
|
|
|
class Person { |
2348
|
|
|
|
|
|
|
has age ( |
2349
|
|
|
|
|
|
|
type => 'Int', |
2350
|
|
|
|
|
|
|
default => 0, |
2351
|
|
|
|
|
|
|
handles_via => 'Counter', |
2352
|
|
|
|
|
|
|
handles => { |
2353
|
|
|
|
|
|
|
birthday => 'inc', # increment age |
2354
|
|
|
|
|
|
|
}, |
2355
|
|
|
|
|
|
|
); |
2356
|
|
|
|
|
|
|
after birthday { |
2357
|
|
|
|
|
|
|
if ($self->age < 30) { |
2358
|
|
|
|
|
|
|
say "yay!"; |
2359
|
|
|
|
|
|
|
} |
2360
|
|
|
|
|
|
|
else { |
2361
|
|
|
|
|
|
|
say "urgh!"; |
2362
|
|
|
|
|
|
|
} |
2363
|
|
|
|
|
|
|
} |
2364
|
|
|
|
|
|
|
} |
2365
|
|
|
|
|
|
|
|
2366
|
|
|
|
|
|
|
A trailing C<< ! >> indicates a required attribute. |
2367
|
|
|
|
|
|
|
|
2368
|
|
|
|
|
|
|
class Person { |
2369
|
|
|
|
|
|
|
has name!; |
2370
|
|
|
|
|
|
|
} |
2371
|
|
|
|
|
|
|
|
2372
|
|
|
|
|
|
|
It is possible to give a default using an equals sign. |
2373
|
|
|
|
|
|
|
|
2374
|
|
|
|
|
|
|
class WidgetCollection { |
2375
|
|
|
|
|
|
|
has name = "Widgets"; |
2376
|
|
|
|
|
|
|
has count (type => Num) = 0; |
2377
|
|
|
|
|
|
|
} |
2378
|
|
|
|
|
|
|
|
2379
|
|
|
|
|
|
|
Note that the default comes after the spec, so in cases where the spec is |
2380
|
|
|
|
|
|
|
long, it may be clearer to express the default inside the spec: |
2381
|
|
|
|
|
|
|
|
2382
|
|
|
|
|
|
|
class WidgetCollection { |
2383
|
|
|
|
|
|
|
has name = "Widgets"; |
2384
|
|
|
|
|
|
|
has count ( |
2385
|
|
|
|
|
|
|
type => Num, |
2386
|
|
|
|
|
|
|
lazy => true, |
2387
|
|
|
|
|
|
|
required => false, |
2388
|
|
|
|
|
|
|
default => 0, |
2389
|
|
|
|
|
|
|
); |
2390
|
|
|
|
|
|
|
} |
2391
|
|
|
|
|
|
|
|
2392
|
|
|
|
|
|
|
Defaults given this way will be eager (non-lazy), but can be made lazy using |
2393
|
|
|
|
|
|
|
the spec: |
2394
|
|
|
|
|
|
|
|
2395
|
|
|
|
|
|
|
class WidgetCollection { |
2396
|
|
|
|
|
|
|
has name = "Widgets"; |
2397
|
|
|
|
|
|
|
has count (is => lazy) = 0; |
2398
|
|
|
|
|
|
|
} |
2399
|
|
|
|
|
|
|
|
2400
|
|
|
|
|
|
|
Defaults I<can> use the C<< $self >> object: |
2401
|
|
|
|
|
|
|
|
2402
|
|
|
|
|
|
|
class WidgetCollection { |
2403
|
|
|
|
|
|
|
has name = "Widgets"; |
2404
|
|
|
|
|
|
|
has display_name = $self->name; |
2405
|
|
|
|
|
|
|
} |
2406
|
|
|
|
|
|
|
|
2407
|
|
|
|
|
|
|
Any default that includes C<< $self >> will automatically be lazy, but can be |
2408
|
|
|
|
|
|
|
made eager using the spec. (It is almost certainly a bad idea to do so though.) |
2409
|
|
|
|
|
|
|
|
2410
|
|
|
|
|
|
|
class WidgetCollection { |
2411
|
|
|
|
|
|
|
has name = "Widgets"; |
2412
|
|
|
|
|
|
|
has display_name ( lazy => false ) = $self->name; |
2413
|
|
|
|
|
|
|
} |
2414
|
|
|
|
|
|
|
|
2415
|
|
|
|
|
|
|
If you need to decide an attribute name on-the-fly, you can replace the |
2416
|
|
|
|
|
|
|
name with a block that returns the name as a string. |
2417
|
|
|
|
|
|
|
|
2418
|
|
|
|
|
|
|
class Employee { |
2419
|
|
|
|
|
|
|
extends Person; |
2420
|
|
|
|
|
|
|
has { |
2421
|
|
|
|
|
|
|
$ENV{LOCALE} eq 'GB' |
2422
|
|
|
|
|
|
|
? 'national_insurance_no' |
2423
|
|
|
|
|
|
|
: 'social_security_no' |
2424
|
|
|
|
|
|
|
} (type => Str) |
2425
|
|
|
|
|
|
|
} |
2426
|
|
|
|
|
|
|
|
2427
|
|
|
|
|
|
|
my $bob = Employee->new( |
2428
|
|
|
|
|
|
|
name => 'Bob', |
2429
|
|
|
|
|
|
|
social_security_no => 1234, |
2430
|
|
|
|
|
|
|
); |
2431
|
|
|
|
|
|
|
|
2432
|
|
|
|
|
|
|
This can be used to define a bunch of types from a list. |
2433
|
|
|
|
|
|
|
|
2434
|
|
|
|
|
|
|
class Person { |
2435
|
|
|
|
|
|
|
my @attrs = qw( name age ); |
2436
|
|
|
|
|
|
|
for my $attr (@attrs) { |
2437
|
|
|
|
|
|
|
has {$attr} ( required => true ); |
2438
|
|
|
|
|
|
|
} |
2439
|
|
|
|
|
|
|
} |
2440
|
|
|
|
|
|
|
|
2441
|
|
|
|
|
|
|
You can think of the syntax as being kind of like C<print>. |
2442
|
|
|
|
|
|
|
|
2443
|
|
|
|
|
|
|
print BAREWORD_FILEHANDLE @strings; |
2444
|
|
|
|
|
|
|
print { block_returning_filehandle(); } @strings; |
2445
|
|
|
|
|
|
|
|
2446
|
|
|
|
|
|
|
The names of attributes can start with an asterisk: |
2447
|
|
|
|
|
|
|
|
2448
|
|
|
|
|
|
|
has *foo; |
2449
|
|
|
|
|
|
|
|
2450
|
|
|
|
|
|
|
This adds no extra meaning, but is supported for consistency with the syntax |
2451
|
|
|
|
|
|
|
of named parameters in method signatures. (Depending on your text editor, it |
2452
|
|
|
|
|
|
|
may also improve syntax highlighting.) |
2453
|
|
|
|
|
|
|
|
2454
|
|
|
|
|
|
|
=head3 C<< constant >> |
2455
|
|
|
|
|
|
|
|
2456
|
|
|
|
|
|
|
class Person { |
2457
|
|
|
|
|
|
|
extends Animal; |
2458
|
|
|
|
|
|
|
constant latin_name = 'Homo sapiens'; |
2459
|
|
|
|
|
|
|
} |
2460
|
|
|
|
|
|
|
|
2461
|
|
|
|
|
|
|
C<< MyApp::Person->latin_name >>, C<< MyApp::Person::latin_name >>, and |
2462
|
|
|
|
|
|
|
C<< $person_object->latin_name >> will return 'Homo sapiens'. |
2463
|
|
|
|
|
|
|
|
2464
|
|
|
|
|
|
|
=head3 C<< method >> |
2465
|
|
|
|
|
|
|
|
2466
|
|
|
|
|
|
|
class Person { |
2467
|
|
|
|
|
|
|
has spouse; |
2468
|
|
|
|
|
|
|
|
2469
|
|
|
|
|
|
|
method marry { |
2470
|
|
|
|
|
|
|
my ($self, $partner) = @_; |
2471
|
|
|
|
|
|
|
$self->spouse($partner); |
2472
|
|
|
|
|
|
|
$partner->spouse($self); |
2473
|
|
|
|
|
|
|
return $self; |
2474
|
|
|
|
|
|
|
} |
2475
|
|
|
|
|
|
|
} |
2476
|
|
|
|
|
|
|
|
2477
|
|
|
|
|
|
|
C<< sub { ... } >> will not work as a way to define methods within the |
2478
|
|
|
|
|
|
|
class. Use C<< method { ... } >> instead. |
2479
|
|
|
|
|
|
|
|
2480
|
|
|
|
|
|
|
The variables C<< $self >> and C<< $class >> will be automatically defined |
2481
|
|
|
|
|
|
|
within all methods. C<< $self >> is set to C<< $_[0] >> (though the invocant |
2482
|
|
|
|
|
|
|
is not shifted off C<< @_ >>). C<< $class >> is set to C<< ref($self)||$self >>. |
2483
|
|
|
|
|
|
|
If the method is called as a class method, both C<< $self >> and C<< $class >> |
2484
|
|
|
|
|
|
|
will be the same thing: the full class name as a string. If the method is |
2485
|
|
|
|
|
|
|
called as an object method, C<< $self >> is the object and C<< $class >> is |
2486
|
|
|
|
|
|
|
its class. |
2487
|
|
|
|
|
|
|
|
2488
|
|
|
|
|
|
|
Like with C<has>, you may use a block that returns a string instead of a |
2489
|
|
|
|
|
|
|
bareword name for the method. |
2490
|
|
|
|
|
|
|
|
2491
|
|
|
|
|
|
|
method {"ma"."rry"} { |
2492
|
|
|
|
|
|
|
...; |
2493
|
|
|
|
|
|
|
} |
2494
|
|
|
|
|
|
|
|
2495
|
|
|
|
|
|
|
MooX::Pression supports method signatures for named arguments and |
2496
|
|
|
|
|
|
|
positional arguments. A mixture of named and positional arguments |
2497
|
|
|
|
|
|
|
is allowed, with some limitations. For anything more complicates, |
2498
|
|
|
|
|
|
|
you should define the method with no signature at all, and unpack |
2499
|
|
|
|
|
|
|
C<< @_ >> within the body of the method. |
2500
|
|
|
|
|
|
|
|
2501
|
|
|
|
|
|
|
=head4 Signatures for Named Arguments |
2502
|
|
|
|
|
|
|
|
2503
|
|
|
|
|
|
|
class Person { |
2504
|
|
|
|
|
|
|
has spouse; |
2505
|
|
|
|
|
|
|
|
2506
|
|
|
|
|
|
|
method marry ( Person *partner, Object *date = DateTime->now ) { |
2507
|
|
|
|
|
|
|
$self->spouse( $arg->partner ); |
2508
|
|
|
|
|
|
|
$arg->partner->spouse( $self ); |
2509
|
|
|
|
|
|
|
return $self; |
2510
|
|
|
|
|
|
|
} |
2511
|
|
|
|
|
|
|
} |
2512
|
|
|
|
|
|
|
|
2513
|
|
|
|
|
|
|
The syntax for each named argument is: |
2514
|
|
|
|
|
|
|
|
2515
|
|
|
|
|
|
|
Type *name = default |
2516
|
|
|
|
|
|
|
|
2517
|
|
|
|
|
|
|
The type is a type name, which will be parsed using L<Type::Parser>. |
2518
|
|
|
|
|
|
|
(So it can include the C<< ~ >>, C<< | >>, and C<< & >>, operators, |
2519
|
|
|
|
|
|
|
and can include parameters in C<< [ ] >> brackets. Type::Parser can |
2520
|
|
|
|
|
|
|
handle whitespace in the type, but not comments. |
2521
|
|
|
|
|
|
|
|
2522
|
|
|
|
|
|
|
Alternatively, you can provide a block which returns a type name as a string |
2523
|
|
|
|
|
|
|
or returns a blessed Type::Tiny object. For very complex types, where you're |
2524
|
|
|
|
|
|
|
expressing additional coercions or value constraints, this is probably what |
2525
|
|
|
|
|
|
|
you want. |
2526
|
|
|
|
|
|
|
|
2527
|
|
|
|
|
|
|
The asterisk indicates that the argument is named, not positional. |
2528
|
|
|
|
|
|
|
|
2529
|
|
|
|
|
|
|
The name may be followed by a question mark to indicate an optional |
2530
|
|
|
|
|
|
|
argument. |
2531
|
|
|
|
|
|
|
|
2532
|
|
|
|
|
|
|
method marry ( Person *partner, Object *date? ) { |
2533
|
|
|
|
|
|
|
...; |
2534
|
|
|
|
|
|
|
} |
2535
|
|
|
|
|
|
|
|
2536
|
|
|
|
|
|
|
Or it may be followed by an equals sign to set a default value. |
2537
|
|
|
|
|
|
|
|
2538
|
|
|
|
|
|
|
Comments may be included in the signature, but not in the middle of |
2539
|
|
|
|
|
|
|
a type constraint. |
2540
|
|
|
|
|
|
|
|
2541
|
|
|
|
|
|
|
method marry ( |
2542
|
|
|
|
|
|
|
# comment here is okay |
2543
|
|
|
|
|
|
|
Person |
2544
|
|
|
|
|
|
|
# comment here is fine too |
2545
|
|
|
|
|
|
|
*partner |
2546
|
|
|
|
|
|
|
# and here |
2547
|
|
|
|
|
|
|
) { ... } |
2548
|
|
|
|
|
|
|
|
2549
|
|
|
|
|
|
|
method marry ( |
2550
|
|
|
|
|
|
|
Person # comment here is not okay! |
2551
|
|
|
|
|
|
|
| Horse |
2552
|
|
|
|
|
|
|
*partner |
2553
|
|
|
|
|
|
|
) { ... } |
2554
|
|
|
|
|
|
|
|
2555
|
|
|
|
|
|
|
As with signature-free methods, C<< $self >> and C<< $class >> wll be |
2556
|
|
|
|
|
|
|
defined for you in the body of the method. However, when a signature |
2557
|
|
|
|
|
|
|
has been used C<< $self >> I<is> shifted off C<< @_ >>. |
2558
|
|
|
|
|
|
|
|
2559
|
|
|
|
|
|
|
Also within the body of the method, a variable called C<< $arg >> |
2560
|
|
|
|
|
|
|
is provided. This is a hashref of the named arguments. So you can |
2561
|
|
|
|
|
|
|
access the partner argument in the above example like this: |
2562
|
|
|
|
|
|
|
|
2563
|
|
|
|
|
|
|
$arg->{partner} |
2564
|
|
|
|
|
|
|
|
2565
|
|
|
|
|
|
|
But because C<< $arg >> is blessed, you can also do: |
2566
|
|
|
|
|
|
|
|
2567
|
|
|
|
|
|
|
$arg->partner |
2568
|
|
|
|
|
|
|
|
2569
|
|
|
|
|
|
|
The latter style is encouraged as it looks neater, plus it helps |
2570
|
|
|
|
|
|
|
catch typos. (C<< $ars->{pratner} >> for example!) However, accessing |
2571
|
|
|
|
|
|
|
it as a plain hashref is supported and shouldn't be considered to be |
2572
|
|
|
|
|
|
|
breaking encapsulation. |
2573
|
|
|
|
|
|
|
|
2574
|
|
|
|
|
|
|
For optional arguments you can check: |
2575
|
|
|
|
|
|
|
|
2576
|
|
|
|
|
|
|
exists($arg->{date}) |
2577
|
|
|
|
|
|
|
|
2578
|
|
|
|
|
|
|
Or: |
2579
|
|
|
|
|
|
|
|
2580
|
|
|
|
|
|
|
$arg->has_date |
2581
|
|
|
|
|
|
|
|
2582
|
|
|
|
|
|
|
For types which have a coercion defined, the value will be automatically |
2583
|
|
|
|
|
|
|
coerced. |
2584
|
|
|
|
|
|
|
|
2585
|
|
|
|
|
|
|
Methods with named arguments can be called with a hash or hashref. |
2586
|
|
|
|
|
|
|
|
2587
|
|
|
|
|
|
|
$alice->marry( partner => $bob ); # okay |
2588
|
|
|
|
|
|
|
$alice->marry({ partner => $bob }); # also okay |
2589
|
|
|
|
|
|
|
|
2590
|
|
|
|
|
|
|
=head4 Signatures for Positional Arguments |
2591
|
|
|
|
|
|
|
|
2592
|
|
|
|
|
|
|
method marry ( Person $partner, Object $date? ) { |
2593
|
|
|
|
|
|
|
$self->spouse( $partner ); |
2594
|
|
|
|
|
|
|
$partner->spouse( $self ); |
2595
|
|
|
|
|
|
|
return $self; |
2596
|
|
|
|
|
|
|
} |
2597
|
|
|
|
|
|
|
|
2598
|
|
|
|
|
|
|
The dollar sign is used instead of an asterisk to indicate a positional |
2599
|
|
|
|
|
|
|
argument. |
2600
|
|
|
|
|
|
|
|
2601
|
|
|
|
|
|
|
As with named arguments, C<< $self >> is automatically shifted off C<< @_ >> |
2602
|
|
|
|
|
|
|
and C<< $class >> exists. Unlike named arguments, there is no C<< $arg >> |
2603
|
|
|
|
|
|
|
variable, and instead a scalar variable is defined for each named argument. |
2604
|
|
|
|
|
|
|
|
2605
|
|
|
|
|
|
|
Optional arguments and defaults are supported in the same way as named |
2606
|
|
|
|
|
|
|
arguments. |
2607
|
|
|
|
|
|
|
|
2608
|
|
|
|
|
|
|
It is possible to include a slurpy hash or array at the end of the list |
2609
|
|
|
|
|
|
|
of positional arguments. |
2610
|
|
|
|
|
|
|
|
2611
|
|
|
|
|
|
|
method marry ( $partner, $date, @vows ) { |
2612
|
|
|
|
|
|
|
...; |
2613
|
|
|
|
|
|
|
} |
2614
|
|
|
|
|
|
|
|
2615
|
|
|
|
|
|
|
If you need to perform a type check on the slurpy parameter, you should |
2616
|
|
|
|
|
|
|
pretend it is a hashref or arrayref. |
2617
|
|
|
|
|
|
|
|
2618
|
|
|
|
|
|
|
method marry ( $partner, $date, ArrayRef[Str] @vows ) { |
2619
|
|
|
|
|
|
|
...; |
2620
|
|
|
|
|
|
|
} |
2621
|
|
|
|
|
|
|
|
2622
|
|
|
|
|
|
|
=head4 Signatures with Mixed Arguments |
2623
|
|
|
|
|
|
|
|
2624
|
|
|
|
|
|
|
Since MooX::Pression 0.200, you may mix named and positional arguments |
2625
|
|
|
|
|
|
|
with the following limitations: |
2626
|
|
|
|
|
|
|
|
2627
|
|
|
|
|
|
|
=over |
2628
|
|
|
|
|
|
|
|
2629
|
|
|
|
|
|
|
=item * |
2630
|
|
|
|
|
|
|
|
2631
|
|
|
|
|
|
|
Positional arguments must appear at the beginning and/or end of the list. |
2632
|
|
|
|
|
|
|
They cannot be surrounded by named arguments. |
2633
|
|
|
|
|
|
|
|
2634
|
|
|
|
|
|
|
=item * |
2635
|
|
|
|
|
|
|
|
2636
|
|
|
|
|
|
|
Positional arguments cannot be optional and cannot have a default. They |
2637
|
|
|
|
|
|
|
must be required. (Named arguments can be optional and have defaults.) |
2638
|
|
|
|
|
|
|
|
2639
|
|
|
|
|
|
|
=item * |
2640
|
|
|
|
|
|
|
|
2641
|
|
|
|
|
|
|
No slurpies! |
2642
|
|
|
|
|
|
|
|
2643
|
|
|
|
|
|
|
=back |
2644
|
|
|
|
|
|
|
|
2645
|
|
|
|
|
|
|
method print_html ($tag, Str $text, *htmlver?, *xml?, $fh) { |
2646
|
|
|
|
|
|
|
|
2647
|
|
|
|
|
|
|
confess "update your HTML" if $arg->htmlver < 5; |
2648
|
|
|
|
|
|
|
|
2649
|
|
|
|
|
|
|
if (length $text) { |
2650
|
|
|
|
|
|
|
print $fh "<tag>$text</tag>"; |
2651
|
|
|
|
|
|
|
} |
2652
|
|
|
|
|
|
|
elsif ($arg->xml) { |
2653
|
|
|
|
|
|
|
print $fh "<tag />"; |
2654
|
|
|
|
|
|
|
} |
2655
|
|
|
|
|
|
|
else { |
2656
|
|
|
|
|
|
|
print $fh "<tag></tag>"; |
2657
|
|
|
|
|
|
|
} |
2658
|
|
|
|
|
|
|
} |
2659
|
|
|
|
|
|
|
|
2660
|
|
|
|
|
|
|
$obj->print_html('h1', 'Hello World', { xml => true }, \*STDOUT); |
2661
|
|
|
|
|
|
|
$obj->print_html('h1', 'Hello World', xml => true , \*STDOUT); |
2662
|
|
|
|
|
|
|
$obj->print_html('h1', 'Hello World', \*STDOUT); |
2663
|
|
|
|
|
|
|
|
2664
|
|
|
|
|
|
|
Mixed signatures are basically implemented like named signatures, but |
2665
|
|
|
|
|
|
|
prior to interpreting C<< @_ >> as a hash, some parameters are spliced |
2666
|
|
|
|
|
|
|
off the head and tail. We need to know how many elements to splice off |
2667
|
|
|
|
|
|
|
each end, so that is why there are restrictions on slurpies and optional |
2668
|
|
|
|
|
|
|
parameters. |
2669
|
|
|
|
|
|
|
|
2670
|
|
|
|
|
|
|
=head4 Empty Signatures |
2671
|
|
|
|
|
|
|
|
2672
|
|
|
|
|
|
|
There is a difference between the following two methods: |
2673
|
|
|
|
|
|
|
|
2674
|
|
|
|
|
|
|
method foo { |
2675
|
|
|
|
|
|
|
...; |
2676
|
|
|
|
|
|
|
} |
2677
|
|
|
|
|
|
|
|
2678
|
|
|
|
|
|
|
method foo () { |
2679
|
|
|
|
|
|
|
...; |
2680
|
|
|
|
|
|
|
} |
2681
|
|
|
|
|
|
|
|
2682
|
|
|
|
|
|
|
In the first, you have not provided a signature and are expected to |
2683
|
|
|
|
|
|
|
deal with C<< @_ >> in the body of the method. In the second, there |
2684
|
|
|
|
|
|
|
is a signature, but it is a signature showing that the method expects |
2685
|
|
|
|
|
|
|
no arguments (other than the invocant of course). |
2686
|
|
|
|
|
|
|
|
2687
|
|
|
|
|
|
|
=head4 Optimizing Methods |
2688
|
|
|
|
|
|
|
|
2689
|
|
|
|
|
|
|
For a slight compiled-time penalty, you can improve the speed which |
2690
|
|
|
|
|
|
|
methods run at using the C<< :optimize >> attribute: |
2691
|
|
|
|
|
|
|
|
2692
|
|
|
|
|
|
|
method foo :optimize (...) { |
2693
|
|
|
|
|
|
|
...; |
2694
|
|
|
|
|
|
|
} |
2695
|
|
|
|
|
|
|
|
2696
|
|
|
|
|
|
|
Optimized methods must not close over any lexical (C<my> or C<our>) |
2697
|
|
|
|
|
|
|
variables; they can only access the variables declared in their, |
2698
|
|
|
|
|
|
|
signature, C<< $self >>, C<< $class >>, C<< @_ >>, and globals. |
2699
|
|
|
|
|
|
|
|
2700
|
|
|
|
|
|
|
=head4 Anonymous Methods |
2701
|
|
|
|
|
|
|
|
2702
|
|
|
|
|
|
|
It I<is> possible to use C<method> without a name to return an |
2703
|
|
|
|
|
|
|
anonymous method (coderef): |
2704
|
|
|
|
|
|
|
|
2705
|
|
|
|
|
|
|
use MooX::Pression prefix => 'MyApp'; |
2706
|
|
|
|
|
|
|
|
2707
|
|
|
|
|
|
|
class MyClass { |
2708
|
|
|
|
|
|
|
method get_method ($foo) { |
2709
|
|
|
|
|
|
|
method ($bar) { |
2710
|
|
|
|
|
|
|
return $foo . $bar; |
2711
|
|
|
|
|
|
|
} |
2712
|
|
|
|
|
|
|
} |
2713
|
|
|
|
|
|
|
} |
2714
|
|
|
|
|
|
|
|
2715
|
|
|
|
|
|
|
my $obj = MyApp->new_myclass; |
2716
|
|
|
|
|
|
|
my $anon = $obj->get_method("FOO"); |
2717
|
|
|
|
|
|
|
say ref($anon); # CODE |
2718
|
|
|
|
|
|
|
say $obj->$anon("BAR"); # FOOBAR |
2719
|
|
|
|
|
|
|
|
2720
|
|
|
|
|
|
|
Note that while C<< $anon >> is a coderef, it is still a method, and |
2721
|
|
|
|
|
|
|
still expects to be passed an object as C<< $self >>. |
2722
|
|
|
|
|
|
|
|
2723
|
|
|
|
|
|
|
Due to limitations with L<Keyword::Simple>, keywords are always |
2724
|
|
|
|
|
|
|
complete statements, so C<< method ... >> has an implicit semicolon |
2725
|
|
|
|
|
|
|
before and after it. This means that this won't work: |
2726
|
|
|
|
|
|
|
|
2727
|
|
|
|
|
|
|
my $x = method { ... }; |
2728
|
|
|
|
|
|
|
|
2729
|
|
|
|
|
|
|
Because it gets treated as: |
2730
|
|
|
|
|
|
|
|
2731
|
|
|
|
|
|
|
my $x = ; |
2732
|
|
|
|
|
|
|
method { ... }; |
2733
|
|
|
|
|
|
|
|
2734
|
|
|
|
|
|
|
A workaround is to wrap it in a C<< do { ... } >> block. |
2735
|
|
|
|
|
|
|
|
2736
|
|
|
|
|
|
|
my $x = do { method { ... } }; |
2737
|
|
|
|
|
|
|
|
2738
|
|
|
|
|
|
|
=head4 Multimethods |
2739
|
|
|
|
|
|
|
|
2740
|
|
|
|
|
|
|
Multi methods should I<< Just Work [tm] >> if you prefix them with the |
2741
|
|
|
|
|
|
|
keyword C<multi> |
2742
|
|
|
|
|
|
|
|
2743
|
|
|
|
|
|
|
use MooX::Pression prefix => 'MyApp'; |
2744
|
|
|
|
|
|
|
|
2745
|
|
|
|
|
|
|
class Widget { |
2746
|
|
|
|
|
|
|
multi method foo :alias(quux) (Any $x) { |
2747
|
|
|
|
|
|
|
say "Buzz"; |
2748
|
|
|
|
|
|
|
} |
2749
|
|
|
|
|
|
|
multi method foo (HashRef $h) { |
2750
|
|
|
|
|
|
|
say "Fizz"; |
2751
|
|
|
|
|
|
|
} |
2752
|
|
|
|
|
|
|
} |
2753
|
|
|
|
|
|
|
|
2754
|
|
|
|
|
|
|
my $thing = MyApp->new_widget; |
2755
|
|
|
|
|
|
|
$thing->foo( {} ); # Fizz |
2756
|
|
|
|
|
|
|
$thing->foo( 42 ); # Buzz |
2757
|
|
|
|
|
|
|
|
2758
|
|
|
|
|
|
|
$thing->quux( {} ); # Buzz |
2759
|
|
|
|
|
|
|
|
2760
|
|
|
|
|
|
|
This feature requires L<MooX::Press> 0.035 and L<Sub::MultiMethod> to be |
2761
|
|
|
|
|
|
|
installed. |
2762
|
|
|
|
|
|
|
|
2763
|
|
|
|
|
|
|
=head3 C<< requires >> |
2764
|
|
|
|
|
|
|
|
2765
|
|
|
|
|
|
|
Indicates that a role requires classes to fulfil certain methods. |
2766
|
|
|
|
|
|
|
|
2767
|
|
|
|
|
|
|
role Payable { |
2768
|
|
|
|
|
|
|
requires account; |
2769
|
|
|
|
|
|
|
requires deposit (Num $amount); |
2770
|
|
|
|
|
|
|
} |
2771
|
|
|
|
|
|
|
|
2772
|
|
|
|
|
|
|
class Employee { |
2773
|
|
|
|
|
|
|
extends Person; |
2774
|
|
|
|
|
|
|
with Payable; |
2775
|
|
|
|
|
|
|
has account!; |
2776
|
|
|
|
|
|
|
method deposit (Num $amount) { |
2777
|
|
|
|
|
|
|
...; |
2778
|
|
|
|
|
|
|
} |
2779
|
|
|
|
|
|
|
} |
2780
|
|
|
|
|
|
|
|
2781
|
|
|
|
|
|
|
Required methods have an optional signature; this is usually ignored, but |
2782
|
|
|
|
|
|
|
if L<Devel::StrictMode> determines that strict behaviour is being used, |
2783
|
|
|
|
|
|
|
the signature will be applied to the method via an C<around> modifier. |
2784
|
|
|
|
|
|
|
|
2785
|
|
|
|
|
|
|
Or to put it another way, this: |
2786
|
|
|
|
|
|
|
|
2787
|
|
|
|
|
|
|
role Payable { |
2788
|
|
|
|
|
|
|
requires account; |
2789
|
|
|
|
|
|
|
requires deposit (Num $amount); |
2790
|
|
|
|
|
|
|
} |
2791
|
|
|
|
|
|
|
|
2792
|
|
|
|
|
|
|
Is a shorthand for this: |
2793
|
|
|
|
|
|
|
|
2794
|
|
|
|
|
|
|
role Payable { |
2795
|
|
|
|
|
|
|
requires account; |
2796
|
|
|
|
|
|
|
requires deposit; |
2797
|
|
|
|
|
|
|
|
2798
|
|
|
|
|
|
|
use Devel::StrictMode 'STRICT'; |
2799
|
|
|
|
|
|
|
if (STRICT) { |
2800
|
|
|
|
|
|
|
around deposit (Num $amount) { |
2801
|
|
|
|
|
|
|
$self->$next(@_); |
2802
|
|
|
|
|
|
|
} |
2803
|
|
|
|
|
|
|
} |
2804
|
|
|
|
|
|
|
} |
2805
|
|
|
|
|
|
|
|
2806
|
|
|
|
|
|
|
=head3 C<< before >> |
2807
|
|
|
|
|
|
|
|
2808
|
|
|
|
|
|
|
before marry { |
2809
|
|
|
|
|
|
|
say "Speak now or forever hold your peace!"; |
2810
|
|
|
|
|
|
|
} |
2811
|
|
|
|
|
|
|
|
2812
|
|
|
|
|
|
|
As with C<method>, C<< $self >> and C<< $class >> are defined. |
2813
|
|
|
|
|
|
|
|
2814
|
|
|
|
|
|
|
As with C<method>, you can provide a signature: |
2815
|
|
|
|
|
|
|
|
2816
|
|
|
|
|
|
|
before marry ( Person $partner, Object $date? ) { |
2817
|
|
|
|
|
|
|
say "Speak now or forever hold your peace!"; |
2818
|
|
|
|
|
|
|
} |
2819
|
|
|
|
|
|
|
|
2820
|
|
|
|
|
|
|
Note that this will result in the argument types being checked/coerced twice; |
2821
|
|
|
|
|
|
|
once by the before method modifier and once by the method itself. Sometimes |
2822
|
|
|
|
|
|
|
this may be desirable, but at other times your before method modifier might |
2823
|
|
|
|
|
|
|
not care about the types of the arguments, so can omit checking them. |
2824
|
|
|
|
|
|
|
|
2825
|
|
|
|
|
|
|
before marry ( $partner, $date? ) { |
2826
|
|
|
|
|
|
|
say "Speak now or forever hold your peace!"; |
2827
|
|
|
|
|
|
|
} |
2828
|
|
|
|
|
|
|
|
2829
|
|
|
|
|
|
|
The C<< :optimize >> attribute is supported for C<before>. |
2830
|
|
|
|
|
|
|
|
2831
|
|
|
|
|
|
|
=head3 C<< after >> |
2832
|
|
|
|
|
|
|
|
2833
|
|
|
|
|
|
|
There's not much to say about C<after>. It's just like C<before>. |
2834
|
|
|
|
|
|
|
|
2835
|
|
|
|
|
|
|
after marry { |
2836
|
|
|
|
|
|
|
say "You may kiss the bride!"; |
2837
|
|
|
|
|
|
|
} |
2838
|
|
|
|
|
|
|
|
2839
|
|
|
|
|
|
|
after marry ( Person $partner, Object $date? ) { |
2840
|
|
|
|
|
|
|
say "You may kiss the bride!"; |
2841
|
|
|
|
|
|
|
} |
2842
|
|
|
|
|
|
|
|
2843
|
|
|
|
|
|
|
after marry ( $partner, $date? ) { |
2844
|
|
|
|
|
|
|
say "You may kiss the bride!"; |
2845
|
|
|
|
|
|
|
} |
2846
|
|
|
|
|
|
|
|
2847
|
|
|
|
|
|
|
The C<< :optimize >> attribute is supported for C<after>. |
2848
|
|
|
|
|
|
|
|
2849
|
|
|
|
|
|
|
=head3 C<< around >> |
2850
|
|
|
|
|
|
|
|
2851
|
|
|
|
|
|
|
The C<around> method modifier is somewhat more interesting. |
2852
|
|
|
|
|
|
|
|
2853
|
|
|
|
|
|
|
around marry ( Person $partner, Object $date? ) { |
2854
|
|
|
|
|
|
|
say "Speak now or forever hold your peace!"; |
2855
|
|
|
|
|
|
|
my $return = $self->$next(@_); |
2856
|
|
|
|
|
|
|
say "You may kiss the bride!"; |
2857
|
|
|
|
|
|
|
return $return; |
2858
|
|
|
|
|
|
|
} |
2859
|
|
|
|
|
|
|
|
2860
|
|
|
|
|
|
|
The C<< $next >> variable holds a coderef pointing to the "original" method |
2861
|
|
|
|
|
|
|
that is being modified. This gives your method modifier the ability to munge |
2862
|
|
|
|
|
|
|
the arguments seen by the "original" method, and munge any return values. |
2863
|
|
|
|
|
|
|
(I say "original" in quote marks because it may not really be the original |
2864
|
|
|
|
|
|
|
method but another wrapper!) |
2865
|
|
|
|
|
|
|
|
2866
|
|
|
|
|
|
|
C<< $next >> and C<< $self >> are both shifted off C<< @_ >>. |
2867
|
|
|
|
|
|
|
|
2868
|
|
|
|
|
|
|
If you use the signature-free version then C<< $next >> and C<< $self >> |
2869
|
|
|
|
|
|
|
are not shifted off C<< @_ >> for you, but the variables are still defined. |
2870
|
|
|
|
|
|
|
|
2871
|
|
|
|
|
|
|
around marry { |
2872
|
|
|
|
|
|
|
say "Speak now or forever hold your peace!"; |
2873
|
|
|
|
|
|
|
my $return = $self->$next($_[2], $_[3]); |
2874
|
|
|
|
|
|
|
say "You may kiss the bride!"; |
2875
|
|
|
|
|
|
|
return $return; |
2876
|
|
|
|
|
|
|
} |
2877
|
|
|
|
|
|
|
|
2878
|
|
|
|
|
|
|
The C<< :optimize >> attribute is supported for C<around>. |
2879
|
|
|
|
|
|
|
|
2880
|
|
|
|
|
|
|
Note that C<< SUPER:: >> won't work as expected in MooX::Pression, so |
2881
|
|
|
|
|
|
|
C<around> should be used instead. |
2882
|
|
|
|
|
|
|
|
2883
|
|
|
|
|
|
|
=head3 C<< factory >> |
2884
|
|
|
|
|
|
|
|
2885
|
|
|
|
|
|
|
The C<factory> keyword is used to define alternative constructors for |
2886
|
|
|
|
|
|
|
your class. |
2887
|
|
|
|
|
|
|
|
2888
|
|
|
|
|
|
|
class Person { |
2889
|
|
|
|
|
|
|
has name ( type => Str, required => true ); |
2890
|
|
|
|
|
|
|
has gender ( type => Str ); |
2891
|
|
|
|
|
|
|
|
2892
|
|
|
|
|
|
|
factory new_man (Str $name) { |
2893
|
|
|
|
|
|
|
return $class->new(name => $name, gender => 'male'); |
2894
|
|
|
|
|
|
|
} |
2895
|
|
|
|
|
|
|
|
2896
|
|
|
|
|
|
|
factory new_woman (Str $name) { |
2897
|
|
|
|
|
|
|
return $class->new(name => $name, gender => 'female'); |
2898
|
|
|
|
|
|
|
} |
2899
|
|
|
|
|
|
|
} |
2900
|
|
|
|
|
|
|
|
2901
|
|
|
|
|
|
|
But here's the twist. These methods are defined within the factory |
2902
|
|
|
|
|
|
|
package, not within the class. |
2903
|
|
|
|
|
|
|
|
2904
|
|
|
|
|
|
|
So you can call: |
2905
|
|
|
|
|
|
|
|
2906
|
|
|
|
|
|
|
MyApp->new_man("Bob") # yes |
2907
|
|
|
|
|
|
|
|
2908
|
|
|
|
|
|
|
But not: |
2909
|
|
|
|
|
|
|
|
2910
|
|
|
|
|
|
|
MyApp::Person->new_man("Bob") # no |
2911
|
|
|
|
|
|
|
|
2912
|
|
|
|
|
|
|
Note that if your class defines I<any> factory methods like this, then the |
2913
|
|
|
|
|
|
|
default factory method (in this case C<< MyApp->new_person >> will no longer |
2914
|
|
|
|
|
|
|
be automatically created. But you can create the default one easily: |
2915
|
|
|
|
|
|
|
|
2916
|
|
|
|
|
|
|
class Person { |
2917
|
|
|
|
|
|
|
has name ( type => Str, required => true ); |
2918
|
|
|
|
|
|
|
has gender ( type => Str ); |
2919
|
|
|
|
|
|
|
|
2920
|
|
|
|
|
|
|
factory new_man (Str $name) { ... } |
2921
|
|
|
|
|
|
|
factory new_woman (Str $name) { ... } |
2922
|
|
|
|
|
|
|
factory new_person; # no method signature or body! |
2923
|
|
|
|
|
|
|
} |
2924
|
|
|
|
|
|
|
|
2925
|
|
|
|
|
|
|
Within a factory method body, the variable C<< $class >> is defined, just |
2926
|
|
|
|
|
|
|
like normal methods, but C<< $self >> is not defined. There is also a |
2927
|
|
|
|
|
|
|
variable C<< $factory >> which is a string containing the factory |
2928
|
|
|
|
|
|
|
package name. This is because you sometimes need to create more than |
2929
|
|
|
|
|
|
|
just one object in a factory method. |
2930
|
|
|
|
|
|
|
|
2931
|
|
|
|
|
|
|
class Wheel; |
2932
|
|
|
|
|
|
|
|
2933
|
|
|
|
|
|
|
class Car { |
2934
|
|
|
|
|
|
|
has wheels = []; |
2935
|
|
|
|
|
|
|
|
2936
|
|
|
|
|
|
|
factory new_three_wheeler () { |
2937
|
|
|
|
|
|
|
return $class->new( |
2938
|
|
|
|
|
|
|
wheels => [ |
2939
|
|
|
|
|
|
|
$factory->new_wheel, |
2940
|
|
|
|
|
|
|
$factory->new_wheel, |
2941
|
|
|
|
|
|
|
$factory->new_wheel, |
2942
|
|
|
|
|
|
|
] |
2943
|
|
|
|
|
|
|
); |
2944
|
|
|
|
|
|
|
} |
2945
|
|
|
|
|
|
|
|
2946
|
|
|
|
|
|
|
factory new_four_wheeler () { |
2947
|
|
|
|
|
|
|
return $class->new( |
2948
|
|
|
|
|
|
|
wheels => [ |
2949
|
|
|
|
|
|
|
$factory->new_wheel, |
2950
|
|
|
|
|
|
|
$factory->new_wheel, |
2951
|
|
|
|
|
|
|
$factory->new_wheel, |
2952
|
|
|
|
|
|
|
$factory->new_wheel, |
2953
|
|
|
|
|
|
|
] |
2954
|
|
|
|
|
|
|
); |
2955
|
|
|
|
|
|
|
} |
2956
|
|
|
|
|
|
|
} |
2957
|
|
|
|
|
|
|
|
2958
|
|
|
|
|
|
|
As with C<method> and the method modifiers, if you provide a signature, |
2959
|
|
|
|
|
|
|
C<< $factory >> and C<< $class >> will be shifted off C<< @_ >>. If you |
2960
|
|
|
|
|
|
|
don't provide a signature, the variables will be defined, but not shifted |
2961
|
|
|
|
|
|
|
off C<< @_ >>. |
2962
|
|
|
|
|
|
|
|
2963
|
|
|
|
|
|
|
An alternative way to provide additional constructors is with C<method> |
2964
|
|
|
|
|
|
|
and then use C<factory> to proxy them. |
2965
|
|
|
|
|
|
|
|
2966
|
|
|
|
|
|
|
class Person { |
2967
|
|
|
|
|
|
|
has name ( type => Str, required => true ); |
2968
|
|
|
|
|
|
|
has gender ( type => Str ); |
2969
|
|
|
|
|
|
|
|
2970
|
|
|
|
|
|
|
method new_guy (Str $name) { ... } |
2971
|
|
|
|
|
|
|
method new_gal (Str $name) { ... } |
2972
|
|
|
|
|
|
|
|
2973
|
|
|
|
|
|
|
factory new_person; |
2974
|
|
|
|
|
|
|
factory new_man via new_guy; |
2975
|
|
|
|
|
|
|
factory new_woman via new_gal; |
2976
|
|
|
|
|
|
|
} |
2977
|
|
|
|
|
|
|
|
2978
|
|
|
|
|
|
|
Now C<< MyApp->new_man >> will call C<< MyApp::Person->new_guy >>. |
2979
|
|
|
|
|
|
|
|
2980
|
|
|
|
|
|
|
C<< factory new_person >> with no C<via> or method body is basically |
2981
|
|
|
|
|
|
|
like saying C<< via new >>. |
2982
|
|
|
|
|
|
|
|
2983
|
|
|
|
|
|
|
The C<< :optimize >> attribute is supported for C<factory>. |
2984
|
|
|
|
|
|
|
|
2985
|
|
|
|
|
|
|
=head4 Implementing a singleton |
2986
|
|
|
|
|
|
|
|
2987
|
|
|
|
|
|
|
Factories make it pretty easy to implement a singleton. |
2988
|
|
|
|
|
|
|
|
2989
|
|
|
|
|
|
|
class AppConfig { |
2990
|
|
|
|
|
|
|
...; |
2991
|
|
|
|
|
|
|
|
2992
|
|
|
|
|
|
|
factory get_appconfig () { |
2993
|
|
|
|
|
|
|
state $config = $class->new(); |
2994
|
|
|
|
|
|
|
} |
2995
|
|
|
|
|
|
|
} |
2996
|
|
|
|
|
|
|
|
2997
|
|
|
|
|
|
|
Now C<< MyApp->get_appconfig >> will always return the same AppConfig object. |
2998
|
|
|
|
|
|
|
Because any explicit use of the C<factory> keyword in a class definition |
2999
|
|
|
|
|
|
|
suppresses the automatic creation of a factory method for the class, there |
3000
|
|
|
|
|
|
|
will be no C<< MyApp->new_appconfig >> method for creating new objects |
3001
|
|
|
|
|
|
|
of that class. |
3002
|
|
|
|
|
|
|
|
3003
|
|
|
|
|
|
|
(People can still manually call C<< MyApp::AppConfig->new >> to get a new |
3004
|
|
|
|
|
|
|
AppConfig object, but remember MooX::Pression discourages calling constructors |
3005
|
|
|
|
|
|
|
directly, and encourages you to use the factory package for instantiating |
3006
|
|
|
|
|
|
|
objects!) |
3007
|
|
|
|
|
|
|
|
3008
|
|
|
|
|
|
|
=head3 C<< type_name >> |
3009
|
|
|
|
|
|
|
|
3010
|
|
|
|
|
|
|
class Homo::Sapiens { |
3011
|
|
|
|
|
|
|
type_name Human; |
3012
|
|
|
|
|
|
|
} |
3013
|
|
|
|
|
|
|
|
3014
|
|
|
|
|
|
|
The class will still be called L<MyApp::Homo::Sapiens> but the type in the |
3015
|
|
|
|
|
|
|
type library will be called B<Human> instead of B<Homo_Sapiens>. |
3016
|
|
|
|
|
|
|
|
3017
|
|
|
|
|
|
|
=head3 C<< coerce >> |
3018
|
|
|
|
|
|
|
|
3019
|
|
|
|
|
|
|
class Person { |
3020
|
|
|
|
|
|
|
has name ( type => Str, required => true ); |
3021
|
|
|
|
|
|
|
has gender ( type => Str ); |
3022
|
|
|
|
|
|
|
|
3023
|
|
|
|
|
|
|
coerce from Str via from_string { |
3024
|
|
|
|
|
|
|
$class->new(name => $_); |
3025
|
|
|
|
|
|
|
} |
3026
|
|
|
|
|
|
|
} |
3027
|
|
|
|
|
|
|
|
3028
|
|
|
|
|
|
|
class Company { |
3029
|
|
|
|
|
|
|
has owner ( type => 'Person', required => true ); |
3030
|
|
|
|
|
|
|
} |
3031
|
|
|
|
|
|
|
|
3032
|
|
|
|
|
|
|
my $acme = MyApp->new_company( owner => "Bob" ); |
3033
|
|
|
|
|
|
|
|
3034
|
|
|
|
|
|
|
Note that the company owner is supposed to be a person object, not a string, |
3035
|
|
|
|
|
|
|
but the Person class knows how create a person object from a string. |
3036
|
|
|
|
|
|
|
|
3037
|
|
|
|
|
|
|
Coercions are automatically enabled in a lot of places for types that have |
3038
|
|
|
|
|
|
|
a coercion. For example, types in signatures, and types in attribute |
3039
|
|
|
|
|
|
|
definitions. |
3040
|
|
|
|
|
|
|
|
3041
|
|
|
|
|
|
|
Note that the coercion body doesn't allow signatures, and the value being |
3042
|
|
|
|
|
|
|
coerced will be found in C<< $_ >>. If you want to have signatures, you |
3043
|
|
|
|
|
|
|
can define a coercion as a normal method first: |
3044
|
|
|
|
|
|
|
|
3045
|
|
|
|
|
|
|
class Person { |
3046
|
|
|
|
|
|
|
has name ( type => Str, required => true ); |
3047
|
|
|
|
|
|
|
has gender ( type => Str ); |
3048
|
|
|
|
|
|
|
|
3049
|
|
|
|
|
|
|
method from_string ( Str $name ) { |
3050
|
|
|
|
|
|
|
$class->new(name => $name); |
3051
|
|
|
|
|
|
|
} |
3052
|
|
|
|
|
|
|
|
3053
|
|
|
|
|
|
|
coerce from Str via from_string; |
3054
|
|
|
|
|
|
|
} |
3055
|
|
|
|
|
|
|
|
3056
|
|
|
|
|
|
|
In both cases, a C<< MyApp::Person->from_string >> method is generated |
3057
|
|
|
|
|
|
|
which can be called to manually coerce a string into a person object. |
3058
|
|
|
|
|
|
|
|
3059
|
|
|
|
|
|
|
They keyword C<< from >> is technically optional, but does make the |
3060
|
|
|
|
|
|
|
statement more readable. |
3061
|
|
|
|
|
|
|
|
3062
|
|
|
|
|
|
|
coerce Str via from_string { # this works |
3063
|
|
|
|
|
|
|
$class->new(name => $_); |
3064
|
|
|
|
|
|
|
} |
3065
|
|
|
|
|
|
|
|
3066
|
|
|
|
|
|
|
The C<< :optimize >> attribute is not currently supported for C<coerce>. |
3067
|
|
|
|
|
|
|
|
3068
|
|
|
|
|
|
|
=head3 C<< overload >> |
3069
|
|
|
|
|
|
|
|
3070
|
|
|
|
|
|
|
class Collection { |
3071
|
|
|
|
|
|
|
has items = []; |
3072
|
|
|
|
|
|
|
overload '@{}' => sub { shift->list }; |
3073
|
|
|
|
|
|
|
} |
3074
|
|
|
|
|
|
|
|
3075
|
|
|
|
|
|
|
The list passed to C<overload> is passed to L<overload> with no other |
3076
|
|
|
|
|
|
|
processing. |
3077
|
|
|
|
|
|
|
|
3078
|
|
|
|
|
|
|
=head3 C<< version >> |
3079
|
|
|
|
|
|
|
|
3080
|
|
|
|
|
|
|
class Person { |
3081
|
|
|
|
|
|
|
version 1.0; |
3082
|
|
|
|
|
|
|
} |
3083
|
|
|
|
|
|
|
|
3084
|
|
|
|
|
|
|
This just sets C<< $MyApp::Person::VERSION >>. |
3085
|
|
|
|
|
|
|
|
3086
|
|
|
|
|
|
|
You can set a default version for all packages like this: |
3087
|
|
|
|
|
|
|
|
3088
|
|
|
|
|
|
|
use MooX::Pression ( |
3089
|
|
|
|
|
|
|
..., |
3090
|
|
|
|
|
|
|
version => 1.0, |
3091
|
|
|
|
|
|
|
); |
3092
|
|
|
|
|
|
|
|
3093
|
|
|
|
|
|
|
If C<class> definitions are nested, C<version> will be inherited by |
3094
|
|
|
|
|
|
|
child classes. If a parent class is specified via C<extends>, C<version> |
3095
|
|
|
|
|
|
|
will not be inherited. |
3096
|
|
|
|
|
|
|
|
3097
|
|
|
|
|
|
|
=head3 C<< authority >> |
3098
|
|
|
|
|
|
|
|
3099
|
|
|
|
|
|
|
class Person { |
3100
|
|
|
|
|
|
|
authority 'cpan:TOBYINK'; |
3101
|
|
|
|
|
|
|
} |
3102
|
|
|
|
|
|
|
|
3103
|
|
|
|
|
|
|
This just sets C<< $MyApp::Person::AUTHORITY >>. |
3104
|
|
|
|
|
|
|
|
3105
|
|
|
|
|
|
|
It is used to indicate who is the maintainer of the package. |
3106
|
|
|
|
|
|
|
|
3107
|
|
|
|
|
|
|
use MooX::Pression ( |
3108
|
|
|
|
|
|
|
..., |
3109
|
|
|
|
|
|
|
version => 1.0, |
3110
|
|
|
|
|
|
|
authority => 'cpan:TOBYINK', |
3111
|
|
|
|
|
|
|
); |
3112
|
|
|
|
|
|
|
|
3113
|
|
|
|
|
|
|
If C<class> definitions are nested, C<authority> will be inherited by |
3114
|
|
|
|
|
|
|
child classes. If a parent class is specified via C<extends>, C<authority> |
3115
|
|
|
|
|
|
|
will not be inherited. |
3116
|
|
|
|
|
|
|
|
3117
|
|
|
|
|
|
|
=head3 C<< include >> |
3118
|
|
|
|
|
|
|
|
3119
|
|
|
|
|
|
|
C<include> is the MooX::Pression equivalent of Perl's C<require>. |
3120
|
|
|
|
|
|
|
|
3121
|
|
|
|
|
|
|
package MyApp { |
3122
|
|
|
|
|
|
|
use MooX::Pression; |
3123
|
|
|
|
|
|
|
include Database; |
3124
|
|
|
|
|
|
|
include Classes; |
3125
|
|
|
|
|
|
|
include Roles; |
3126
|
|
|
|
|
|
|
} |
3127
|
|
|
|
|
|
|
|
3128
|
|
|
|
|
|
|
It works somewhat more crudely than C<require> and C<use>, evaluating |
3129
|
|
|
|
|
|
|
the included file pretty much as if it had been copy and pasted into the |
3130
|
|
|
|
|
|
|
file that included it. |
3131
|
|
|
|
|
|
|
|
3132
|
|
|
|
|
|
|
The names of the files to load are processsed using the same rules for |
3133
|
|
|
|
|
|
|
prefixes as classes and roles (so MyApp::Database, etc in the example), |
3134
|
|
|
|
|
|
|
and C<< @INC >> is searched just like C<require> and C<use> do, but |
3135
|
|
|
|
|
|
|
instead of looking for a file called "MyApp/Database.pm", MooX::Pression |
3136
|
|
|
|
|
|
|
will look for "MyApp/Database.pl" (yes, ".pl"). This naming convention |
3137
|
|
|
|
|
|
|
ensures people won't accidentally load MyApp::Database using C<use> |
3138
|
|
|
|
|
|
|
or C<require> because it isn't intended to be loaded outside the context |
3139
|
|
|
|
|
|
|
of the MyApp package. |
3140
|
|
|
|
|
|
|
|
3141
|
|
|
|
|
|
|
The file "MyApp/Database.pl" might look something like this: |
3142
|
|
|
|
|
|
|
|
3143
|
|
|
|
|
|
|
class Database { |
3144
|
|
|
|
|
|
|
has dbh = DBI->connect(...); |
3145
|
|
|
|
|
|
|
|
3146
|
|
|
|
|
|
|
factory get_db { |
3147
|
|
|
|
|
|
|
state $instance = $class->new; |
3148
|
|
|
|
|
|
|
} |
3149
|
|
|
|
|
|
|
} |
3150
|
|
|
|
|
|
|
|
3151
|
|
|
|
|
|
|
Note that it doesn't start with a C<package> statement, nor |
3152
|
|
|
|
|
|
|
C<use MooX::Pression>. It's just straight on to the definitions. |
3153
|
|
|
|
|
|
|
There's no C<< 1; >> needed at the end. |
3154
|
|
|
|
|
|
|
|
3155
|
|
|
|
|
|
|
C<< use strict >> and C<< use warnings >> are safe to put in the |
3156
|
|
|
|
|
|
|
file if you need them to satisfy linters, but they're not necessary |
3157
|
|
|
|
|
|
|
because the contents of the file are evaluated as if they had been |
3158
|
|
|
|
|
|
|
copied and pasted into the main MyApp module. |
3159
|
|
|
|
|
|
|
|
3160
|
|
|
|
|
|
|
There are I<no> checks to prevent a file from being included more than |
3161
|
|
|
|
|
|
|
once, and there are I<no> checks to deal with cyclical inclusions. |
3162
|
|
|
|
|
|
|
|
3163
|
|
|
|
|
|
|
Inclusions are currently only supported at the top level, and not within |
3164
|
|
|
|
|
|
|
class and role definitions. |
3165
|
|
|
|
|
|
|
|
3166
|
|
|
|
|
|
|
=head3 C<< MooX::Pression::PACKAGE_SPEC() >> |
3167
|
|
|
|
|
|
|
|
3168
|
|
|
|
|
|
|
This function can be used while a class or role is being compiled to |
3169
|
|
|
|
|
|
|
tweak the specification for the class/role. |
3170
|
|
|
|
|
|
|
|
3171
|
|
|
|
|
|
|
class Foo { |
3172
|
|
|
|
|
|
|
has foo; |
3173
|
|
|
|
|
|
|
MooX::Pression::PACKAGE_SPEC->{has}{foo}{type} = Int; |
3174
|
|
|
|
|
|
|
} |
3175
|
|
|
|
|
|
|
|
3176
|
|
|
|
|
|
|
It returns a hashref of attributes, methods, etc. L<MooX::Press> should |
3177
|
|
|
|
|
|
|
give you an idea about how the hashref is structured, but MooX::Pression |
3178
|
|
|
|
|
|
|
only supports a subset of what MooX::Press supports. For example, MooX::Press |
3179
|
|
|
|
|
|
|
allows C<has> to be an arrayref or a hashref, but MooX::Pression only supports |
3180
|
|
|
|
|
|
|
a hashref. The exact subset that MooX::Pression supports is subject to change |
3181
|
|
|
|
|
|
|
without notice. |
3182
|
|
|
|
|
|
|
|
3183
|
|
|
|
|
|
|
This can be used to access MooX::Press features that MooX::Pression doesn't |
3184
|
|
|
|
|
|
|
expose. |
3185
|
|
|
|
|
|
|
|
3186
|
|
|
|
|
|
|
=head2 Helper Subs |
3187
|
|
|
|
|
|
|
|
3188
|
|
|
|
|
|
|
Earlier it was stated that C<sub> cannot be used to define methods in |
3189
|
|
|
|
|
|
|
classes and roles. This is true, but that doesn't mean that it has no |
3190
|
|
|
|
|
|
|
use. |
3191
|
|
|
|
|
|
|
|
3192
|
|
|
|
|
|
|
package MyApp { |
3193
|
|
|
|
|
|
|
use MooX::Pression; |
3194
|
|
|
|
|
|
|
|
3195
|
|
|
|
|
|
|
sub helper_function { ... } |
3196
|
|
|
|
|
|
|
|
3197
|
|
|
|
|
|
|
class Foo { |
3198
|
|
|
|
|
|
|
method foo { |
3199
|
|
|
|
|
|
|
...; |
3200
|
|
|
|
|
|
|
helper_function(...); |
3201
|
|
|
|
|
|
|
...; |
3202
|
|
|
|
|
|
|
} |
3203
|
|
|
|
|
|
|
} |
3204
|
|
|
|
|
|
|
|
3205
|
|
|
|
|
|
|
class Bar { |
3206
|
|
|
|
|
|
|
sub other_helper { ... } |
3207
|
|
|
|
|
|
|
method bar { |
3208
|
|
|
|
|
|
|
...; |
3209
|
|
|
|
|
|
|
helper_function(...); |
3210
|
|
|
|
|
|
|
other_helper(...); |
3211
|
|
|
|
|
|
|
...; |
3212
|
|
|
|
|
|
|
} |
3213
|
|
|
|
|
|
|
} |
3214
|
|
|
|
|
|
|
} |
3215
|
|
|
|
|
|
|
|
3216
|
|
|
|
|
|
|
The subs defined by C<sub> end up in the "MyApp" package, not |
3217
|
|
|
|
|
|
|
"MyApp::Foo" or "MyApp::Bar". They can be called by any of the classes |
3218
|
|
|
|
|
|
|
and roles defined in MyApp. This makes them suitable for helper subs |
3219
|
|
|
|
|
|
|
like logging, L<List::Util>/L<Scalar::Util> sorts of functions, and |
3220
|
|
|
|
|
|
|
so on. |
3221
|
|
|
|
|
|
|
|
3222
|
|
|
|
|
|
|
package MyApp { |
3223
|
|
|
|
|
|
|
use MooX::Pression; |
3224
|
|
|
|
|
|
|
|
3225
|
|
|
|
|
|
|
use List::Util qw( any all first reduce ); |
3226
|
|
|
|
|
|
|
# the above functions are now available within |
3227
|
|
|
|
|
|
|
# all of MyApp's classes and roles, but won't |
3228
|
|
|
|
|
|
|
# pollute any of their namespaces. |
3229
|
|
|
|
|
|
|
|
3230
|
|
|
|
|
|
|
use namespace::clean; |
3231
|
|
|
|
|
|
|
# And now they won't even pollute MyApp's namespace. |
3232
|
|
|
|
|
|
|
# Though I'm pretty sure this will also stop them |
3233
|
|
|
|
|
|
|
# from working in any methods that used ":optimize". |
3234
|
|
|
|
|
|
|
|
3235
|
|
|
|
|
|
|
class Foo { ... } |
3236
|
|
|
|
|
|
|
role Bar { ... } |
3237
|
|
|
|
|
|
|
role Baz { ... } |
3238
|
|
|
|
|
|
|
} |
3239
|
|
|
|
|
|
|
|
3240
|
|
|
|
|
|
|
C<sub> is also usually your best option for those tiny little |
3241
|
|
|
|
|
|
|
coderefs that need to be defined here and there: |
3242
|
|
|
|
|
|
|
|
3243
|
|
|
|
|
|
|
has foo ( |
3244
|
|
|
|
|
|
|
is => lazy, |
3245
|
|
|
|
|
|
|
type => ArrayRef[Str], |
3246
|
|
|
|
|
|
|
builder => sub { [] }, |
3247
|
|
|
|
|
|
|
); |
3248
|
|
|
|
|
|
|
|
3249
|
|
|
|
|
|
|
Though consider using L<Sub::Quote> if you're using Moo. |
3250
|
|
|
|
|
|
|
|
3251
|
|
|
|
|
|
|
=head2 Utilities |
3252
|
|
|
|
|
|
|
|
3253
|
|
|
|
|
|
|
MooX::Pression also exports constants C<true> and C<false> into your |
3254
|
|
|
|
|
|
|
namespace. These show clearer boolean intent in code than using 1 and 0. |
3255
|
|
|
|
|
|
|
|
3256
|
|
|
|
|
|
|
MooX::Pression exports C<rw>, C<ro>, C<rwp>, and C<lazy> constants |
3257
|
|
|
|
|
|
|
which make your attribute specs a little cleaner looking. |
3258
|
|
|
|
|
|
|
|
3259
|
|
|
|
|
|
|
MooX::Pression exports C<blessed> from L<Scalar::Util> because that can |
3260
|
|
|
|
|
|
|
be handy to have, and C<confess> from L<Carp>. MooX::Pression's copy |
3261
|
|
|
|
|
|
|
of C<confess> is super-powered and runs its arguments through C<sprintf>. |
3262
|
|
|
|
|
|
|
|
3263
|
|
|
|
|
|
|
before vote { |
3264
|
|
|
|
|
|
|
if ($self->age < 18) { |
3265
|
|
|
|
|
|
|
confess("Can't vote, only %d", $self->age); |
3266
|
|
|
|
|
|
|
} |
3267
|
|
|
|
|
|
|
} |
3268
|
|
|
|
|
|
|
|
3269
|
|
|
|
|
|
|
MooX::Pression turns on strict, warnings, and the following modern Perl |
3270
|
|
|
|
|
|
|
features: |
3271
|
|
|
|
|
|
|
|
3272
|
|
|
|
|
|
|
# Perl 5.14 and Perl 5.16 |
3273
|
|
|
|
|
|
|
say state unicode_strings |
3274
|
|
|
|
|
|
|
|
3275
|
|
|
|
|
|
|
# Perl 5.18 or above |
3276
|
|
|
|
|
|
|
say state unicode_strings unicode_eval evalbytes current_sub fc |
3277
|
|
|
|
|
|
|
|
3278
|
|
|
|
|
|
|
If you're wondering why not other features, it's because I didn't want to |
3279
|
|
|
|
|
|
|
enable any that are currently classed as experimental, nor any that require |
3280
|
|
|
|
|
|
|
a version of Perl above 5.18. The C<switch> feature is mostly seen as a |
3281
|
|
|
|
|
|
|
failed experiment these days, and C<lexical_subs> cannot be called as methods |
3282
|
|
|
|
|
|
|
so are less useful in object-oriented code. |
3283
|
|
|
|
|
|
|
|
3284
|
|
|
|
|
|
|
You can, of course, turn on extra features yourself. |
3285
|
|
|
|
|
|
|
|
3286
|
|
|
|
|
|
|
package MyApp { |
3287
|
|
|
|
|
|
|
use MooX::Pression; |
3288
|
|
|
|
|
|
|
use feature qw( lexical_subs postderef ); |
3289
|
|
|
|
|
|
|
|
3290
|
|
|
|
|
|
|
...; |
3291
|
|
|
|
|
|
|
} |
3292
|
|
|
|
|
|
|
|
3293
|
|
|
|
|
|
|
(The C<current_sub> feature is unlikely to work fully unless you |
3294
|
|
|
|
|
|
|
have C<:optimize> switched on for that method, or the method does not |
3295
|
|
|
|
|
|
|
include a signature. For non-optimized methods with a signature, a |
3296
|
|
|
|
|
|
|
wrapper is installed that handles checks, coercions, and defaults. |
3297
|
|
|
|
|
|
|
C<< __SUB__ >> will point to the "inner" sub, minus the wrapper.) |
3298
|
|
|
|
|
|
|
|
3299
|
|
|
|
|
|
|
MooX::Pression exports L<Syntax::Keyword::Try> for you. Useful to have. |
3300
|
|
|
|
|
|
|
|
3301
|
|
|
|
|
|
|
And last but not least, it exports all the types, C<< is_* >> functions, |
3302
|
|
|
|
|
|
|
and C<< assert_* >> functions from L<Types::Standard>, |
3303
|
|
|
|
|
|
|
L<Types::Common::String>, and L<Types::Common::Numeric>. |
3304
|
|
|
|
|
|
|
|
3305
|
|
|
|
|
|
|
=head2 Anonymous Classes and Roles |
3306
|
|
|
|
|
|
|
|
3307
|
|
|
|
|
|
|
=head3 Anonymous classes |
3308
|
|
|
|
|
|
|
|
3309
|
|
|
|
|
|
|
It is possible to make anonymous classes: |
3310
|
|
|
|
|
|
|
|
3311
|
|
|
|
|
|
|
my $class = do { class; }; |
3312
|
|
|
|
|
|
|
my $object = $class->new; |
3313
|
|
|
|
|
|
|
|
3314
|
|
|
|
|
|
|
The C<< do { ... } >> block is necessary because of a limitation in |
3315
|
|
|
|
|
|
|
L<Keyword::Simple>, where any keywords it defines must be complete |
3316
|
|
|
|
|
|
|
statements. |
3317
|
|
|
|
|
|
|
|
3318
|
|
|
|
|
|
|
Anonymous classes can have methods and attributes and so on: |
3319
|
|
|
|
|
|
|
|
3320
|
|
|
|
|
|
|
my $class = do { class { |
3321
|
|
|
|
|
|
|
has foo (type => Int); |
3322
|
|
|
|
|
|
|
has bar (type => Int); |
3323
|
|
|
|
|
|
|
}}; |
3324
|
|
|
|
|
|
|
|
3325
|
|
|
|
|
|
|
my $object = $class->new(foo => 1, bar => 2); |
3326
|
|
|
|
|
|
|
|
3327
|
|
|
|
|
|
|
Anonymous classes I<do not> implicitly inherit from their parent like |
3328
|
|
|
|
|
|
|
named nested classes do. Named classes nested inside anonymous classes |
3329
|
|
|
|
|
|
|
I<do not> implicitly inherit from the anonymous class. |
3330
|
|
|
|
|
|
|
|
3331
|
|
|
|
|
|
|
Having one anonymous class inherit from another can be done though: |
3332
|
|
|
|
|
|
|
|
3333
|
|
|
|
|
|
|
my $base = do { class; } |
3334
|
|
|
|
|
|
|
my $derived = do { class { |
3335
|
|
|
|
|
|
|
extends {"::$k1"}; |
3336
|
|
|
|
|
|
|
}}; |
3337
|
|
|
|
|
|
|
|
3338
|
|
|
|
|
|
|
This works because C<extends> accepts a block which returns a string for |
3339
|
|
|
|
|
|
|
the package name, and the string needs to begin with "::" to avoid the |
3340
|
|
|
|
|
|
|
auto prefix mechanism. |
3341
|
|
|
|
|
|
|
|
3342
|
|
|
|
|
|
|
=head3 Anonymous roles |
3343
|
|
|
|
|
|
|
|
3344
|
|
|
|
|
|
|
Anonymous roles work in much the same way. |
3345
|
|
|
|
|
|
|
|
3346
|
|
|
|
|
|
|
=head2 Parameterizable Classes and Roles |
3347
|
|
|
|
|
|
|
|
3348
|
|
|
|
|
|
|
=head3 Parameterizable classes |
3349
|
|
|
|
|
|
|
|
3350
|
|
|
|
|
|
|
package MyApp { |
3351
|
|
|
|
|
|
|
use MooX::Pression; |
3352
|
|
|
|
|
|
|
|
3353
|
|
|
|
|
|
|
class Animal { |
3354
|
|
|
|
|
|
|
has name; |
3355
|
|
|
|
|
|
|
} |
3356
|
|
|
|
|
|
|
|
3357
|
|
|
|
|
|
|
class Species ( Str $common_name, Str $binomial ) { |
3358
|
|
|
|
|
|
|
extends Animal; |
3359
|
|
|
|
|
|
|
constant common_name = $common_name; |
3360
|
|
|
|
|
|
|
constant binomial = $binomial; |
3361
|
|
|
|
|
|
|
} |
3362
|
|
|
|
|
|
|
|
3363
|
|
|
|
|
|
|
class Dog { |
3364
|
|
|
|
|
|
|
extends Species('dog', 'Canis familiaris'); |
3365
|
|
|
|
|
|
|
method bark () { |
3366
|
|
|
|
|
|
|
say "woof!"; |
3367
|
|
|
|
|
|
|
} |
3368
|
|
|
|
|
|
|
} |
3369
|
|
|
|
|
|
|
} |
3370
|
|
|
|
|
|
|
|
3371
|
|
|
|
|
|
|
Here, "MyApp::Species" isn't a class in the usual sense; you cannot create |
3372
|
|
|
|
|
|
|
instances of it. It's like a template for generating classes. Then |
3373
|
|
|
|
|
|
|
"MyApp::Dog" generates a class from the template and inherits from that. |
3374
|
|
|
|
|
|
|
|
3375
|
|
|
|
|
|
|
my $Cat = MyApp->generate_species('cat', 'Felis catus'); |
3376
|
|
|
|
|
|
|
my $mog = $Cat->new(name => 'Mog'); |
3377
|
|
|
|
|
|
|
|
3378
|
|
|
|
|
|
|
$mog->isa('MyApp::Animal'); # true |
3379
|
|
|
|
|
|
|
$mog->isa('MyApp::Species'); # false!!! |
3380
|
|
|
|
|
|
|
$mog->isa($Cat); # true |
3381
|
|
|
|
|
|
|
|
3382
|
|
|
|
|
|
|
Because there are never any instances of "MyApp::Species", it doesn't |
3383
|
|
|
|
|
|
|
make sense to have a B<Species> type constraint. Instead there are |
3384
|
|
|
|
|
|
|
B<SpeciesClass> and B<SpeciesInstance> type constraints. |
3385
|
|
|
|
|
|
|
|
3386
|
|
|
|
|
|
|
use MyApp::Types -is; |
3387
|
|
|
|
|
|
|
|
3388
|
|
|
|
|
|
|
my $lassie = MyApp->new_dog; |
3389
|
|
|
|
|
|
|
|
3390
|
|
|
|
|
|
|
is_Animal( $lassie ); # true |
3391
|
|
|
|
|
|
|
is_Dog( $lassie ); # true |
3392
|
|
|
|
|
|
|
is_SpeciesInstance( $lassie ); # true |
3393
|
|
|
|
|
|
|
is_SpeciesClass( ref($lassie) ); # true |
3394
|
|
|
|
|
|
|
|
3395
|
|
|
|
|
|
|
Subclasses cannot be nested inside parameterizable classes, but |
3396
|
|
|
|
|
|
|
parameterizable classes can be nested inside regular classes, in |
3397
|
|
|
|
|
|
|
which case the classes they generate will inherit from the outer |
3398
|
|
|
|
|
|
|
class. |
3399
|
|
|
|
|
|
|
|
3400
|
|
|
|
|
|
|
package MyApp { |
3401
|
|
|
|
|
|
|
use MooX::Pression; |
3402
|
|
|
|
|
|
|
|
3403
|
|
|
|
|
|
|
class Animal { |
3404
|
|
|
|
|
|
|
has name; |
3405
|
|
|
|
|
|
|
class Species ( Str $common_name, Str $binomial ) { |
3406
|
|
|
|
|
|
|
constant common_name = $common_name; |
3407
|
|
|
|
|
|
|
constant binomial = $binomial; |
3408
|
|
|
|
|
|
|
} |
3409
|
|
|
|
|
|
|
} |
3410
|
|
|
|
|
|
|
|
3411
|
|
|
|
|
|
|
class Dog { |
3412
|
|
|
|
|
|
|
extends Species('dog', 'Canis familiaris'); |
3413
|
|
|
|
|
|
|
method bark () { |
3414
|
|
|
|
|
|
|
say "woof!"; |
3415
|
|
|
|
|
|
|
} |
3416
|
|
|
|
|
|
|
} |
3417
|
|
|
|
|
|
|
} |
3418
|
|
|
|
|
|
|
|
3419
|
|
|
|
|
|
|
Anonymous parameterizable classes are possible: |
3420
|
|
|
|
|
|
|
|
3421
|
|
|
|
|
|
|
my $generator = do { class ($footype, $bartype) { |
3422
|
|
|
|
|
|
|
has foo (type => $footype); |
3423
|
|
|
|
|
|
|
has bar (type => $bartype); |
3424
|
|
|
|
|
|
|
}; |
3425
|
|
|
|
|
|
|
|
3426
|
|
|
|
|
|
|
my $class = $generator->generate_package(Int, Num); |
3427
|
|
|
|
|
|
|
|
3428
|
|
|
|
|
|
|
my $object = $class->new(foo => 42, bar => 4.2); |
3429
|
|
|
|
|
|
|
|
3430
|
|
|
|
|
|
|
=head3 Parameterizable roles |
3431
|
|
|
|
|
|
|
|
3432
|
|
|
|
|
|
|
Often it makes more sense to parameterize roles than classes. |
3433
|
|
|
|
|
|
|
|
3434
|
|
|
|
|
|
|
package MyApp { |
3435
|
|
|
|
|
|
|
use MooX::Pression; |
3436
|
|
|
|
|
|
|
|
3437
|
|
|
|
|
|
|
class Animal { |
3438
|
|
|
|
|
|
|
has name; |
3439
|
|
|
|
|
|
|
} |
3440
|
|
|
|
|
|
|
|
3441
|
|
|
|
|
|
|
role Species ( Str $common_name, Str $binomial ) { |
3442
|
|
|
|
|
|
|
constant common_name = $common_name; |
3443
|
|
|
|
|
|
|
constant binomial = $binomial; |
3444
|
|
|
|
|
|
|
} |
3445
|
|
|
|
|
|
|
|
3446
|
|
|
|
|
|
|
class Dog { |
3447
|
|
|
|
|
|
|
extends Animal; |
3448
|
|
|
|
|
|
|
with Species('dog', 'Canis familiaris'), GoodBoi?; |
3449
|
|
|
|
|
|
|
method bark () { |
3450
|
|
|
|
|
|
|
say "woof!"; |
3451
|
|
|
|
|
|
|
} |
3452
|
|
|
|
|
|
|
} |
3453
|
|
|
|
|
|
|
} |
3454
|
|
|
|
|
|
|
|
3455
|
|
|
|
|
|
|
Anonymous parameterizable roles are possible. |
3456
|
|
|
|
|
|
|
|
3457
|
|
|
|
|
|
|
=head2 MooX::Pression vs Moops |
3458
|
|
|
|
|
|
|
|
3459
|
|
|
|
|
|
|
MooX::Pression has fewer dependencies than Moops, and crucially doesn't |
3460
|
|
|
|
|
|
|
rely on L<Package::Keyword> and L<Devel::CallParser> which have... issues. |
3461
|
|
|
|
|
|
|
MooX::Pression uses Damian Conway's excellent L<PPR> to handle most parsing |
3462
|
|
|
|
|
|
|
needs, so parsing should be more predictable. |
3463
|
|
|
|
|
|
|
|
3464
|
|
|
|
|
|
|
Moops is faster though. |
3465
|
|
|
|
|
|
|
|
3466
|
|
|
|
|
|
|
Here are a few key syntax and feature differences. |
3467
|
|
|
|
|
|
|
|
3468
|
|
|
|
|
|
|
=head3 Declaring a class |
3469
|
|
|
|
|
|
|
|
3470
|
|
|
|
|
|
|
Moops: |
3471
|
|
|
|
|
|
|
|
3472
|
|
|
|
|
|
|
class Foo::Bar 1.0 extends Foo with Bar { |
3473
|
|
|
|
|
|
|
...; |
3474
|
|
|
|
|
|
|
} |
3475
|
|
|
|
|
|
|
|
3476
|
|
|
|
|
|
|
MooX::Pression: |
3477
|
|
|
|
|
|
|
|
3478
|
|
|
|
|
|
|
class Foo::Bar { |
3479
|
|
|
|
|
|
|
version 1.0; |
3480
|
|
|
|
|
|
|
extends Foo; |
3481
|
|
|
|
|
|
|
with Bar; |
3482
|
|
|
|
|
|
|
} |
3483
|
|
|
|
|
|
|
|
3484
|
|
|
|
|
|
|
Moops and MooX::Pression use different logic for determining whether a class |
3485
|
|
|
|
|
|
|
name is "absolute" or "relative". In Moops, classes containing a "::" are seen |
3486
|
|
|
|
|
|
|
as absolute class names; in MooX::Pression, only classes I<starting with> "::" |
3487
|
|
|
|
|
|
|
are taken to be absolute; all others are given the prefix. |
3488
|
|
|
|
|
|
|
|
3489
|
|
|
|
|
|
|
Moops: |
3490
|
|
|
|
|
|
|
|
3491
|
|
|
|
|
|
|
package MyApp { |
3492
|
|
|
|
|
|
|
use Moops; |
3493
|
|
|
|
|
|
|
class Foo { |
3494
|
|
|
|
|
|
|
class Bar { |
3495
|
|
|
|
|
|
|
class Baz { |
3496
|
|
|
|
|
|
|
# Nesting class blocks establishes a naming |
3497
|
|
|
|
|
|
|
# heirarchy so this is MyApp::Foo::Bar::Baz! |
3498
|
|
|
|
|
|
|
} |
3499
|
|
|
|
|
|
|
} |
3500
|
|
|
|
|
|
|
} |
3501
|
|
|
|
|
|
|
} |
3502
|
|
|
|
|
|
|
|
3503
|
|
|
|
|
|
|
MooX::Pression: |
3504
|
|
|
|
|
|
|
|
3505
|
|
|
|
|
|
|
package MyApp { |
3506
|
|
|
|
|
|
|
use MooX::Pression; |
3507
|
|
|
|
|
|
|
class Foo { |
3508
|
|
|
|
|
|
|
class Bar { |
3509
|
|
|
|
|
|
|
class Baz { |
3510
|
|
|
|
|
|
|
# This is only MyApp::Baz, but nesting |
3511
|
|
|
|
|
|
|
# establishes an @ISA chain instead. |
3512
|
|
|
|
|
|
|
} |
3513
|
|
|
|
|
|
|
} |
3514
|
|
|
|
|
|
|
} |
3515
|
|
|
|
|
|
|
} |
3516
|
|
|
|
|
|
|
|
3517
|
|
|
|
|
|
|
=head3 How namespacing works |
3518
|
|
|
|
|
|
|
|
3519
|
|
|
|
|
|
|
Moops: |
3520
|
|
|
|
|
|
|
|
3521
|
|
|
|
|
|
|
use feature 'say'; |
3522
|
|
|
|
|
|
|
package MyApp { |
3523
|
|
|
|
|
|
|
use Moops; |
3524
|
|
|
|
|
|
|
use List::Util qw(uniq); |
3525
|
|
|
|
|
|
|
class Foo { |
3526
|
|
|
|
|
|
|
say __PACKAGE__; # MyApp::Foo |
3527
|
|
|
|
|
|
|
say for uniq(1,2,1,3); # ERROR! |
3528
|
|
|
|
|
|
|
sub foo { ... } # MyApp::Foo::foo() |
3529
|
|
|
|
|
|
|
} |
3530
|
|
|
|
|
|
|
} |
3531
|
|
|
|
|
|
|
|
3532
|
|
|
|
|
|
|
MooX::Pression: |
3533
|
|
|
|
|
|
|
|
3534
|
|
|
|
|
|
|
use feature 'say'; |
3535
|
|
|
|
|
|
|
package MyApp { |
3536
|
|
|
|
|
|
|
use MooX::Pression; |
3537
|
|
|
|
|
|
|
use List::Util qw(uniq); |
3538
|
|
|
|
|
|
|
class Foo { |
3539
|
|
|
|
|
|
|
say __PACKAGE__; # MyApp |
3540
|
|
|
|
|
|
|
say for uniq(1,2,1,3); # this works fine |
3541
|
|
|
|
|
|
|
sub foo { ... } # MyApp::foo() |
3542
|
|
|
|
|
|
|
} |
3543
|
|
|
|
|
|
|
} |
3544
|
|
|
|
|
|
|
|
3545
|
|
|
|
|
|
|
This is why you can't use C<sub> to define methods in MooX::Pression. |
3546
|
|
|
|
|
|
|
You need to use the C<method> keyword. In MooX::Pression, all the code |
3547
|
|
|
|
|
|
|
in the class definition block is still executing in the parent |
3548
|
|
|
|
|
|
|
package's namespace! |
3549
|
|
|
|
|
|
|
|
3550
|
|
|
|
|
|
|
=head3 Multimethods |
3551
|
|
|
|
|
|
|
|
3552
|
|
|
|
|
|
|
Moops/Kavorka multimethods are faster, but MooX::Pression is smarter at |
3553
|
|
|
|
|
|
|
picking the best candidate to dispatch to, and intelligently selecting |
3554
|
|
|
|
|
|
|
candidates across inheritance hierarchies and role compositions. |
3555
|
|
|
|
|
|
|
|
3556
|
|
|
|
|
|
|
=head3 Other crazy Kavorka features |
3557
|
|
|
|
|
|
|
|
3558
|
|
|
|
|
|
|
Kavorka allows you to mark certain parameters as read-only or aliases, |
3559
|
|
|
|
|
|
|
allows you to specify multiple names for named parameters, allows you |
3560
|
|
|
|
|
|
|
to rename the invocant, allows you to give methods and parameters |
3561
|
|
|
|
|
|
|
attributes, allows you to specify a method's return type, etc, etc. |
3562
|
|
|
|
|
|
|
|
3563
|
|
|
|
|
|
|
MooX::Pression's C<method> keyword is unlikely to ever offer as many |
3564
|
|
|
|
|
|
|
features as that. It is unlikely to offer many more features than it |
3565
|
|
|
|
|
|
|
currently offers. |
3566
|
|
|
|
|
|
|
|
3567
|
|
|
|
|
|
|
If you need fine-grained control over how C<< @_ >> is handled, just |
3568
|
|
|
|
|
|
|
don't use a signature and unpack C<< @_ >> inside your method body |
3569
|
|
|
|
|
|
|
however you need to. |
3570
|
|
|
|
|
|
|
|
3571
|
|
|
|
|
|
|
=head3 Lexical accessors |
3572
|
|
|
|
|
|
|
|
3573
|
|
|
|
|
|
|
Moops automatically imported C<lexical_has> from L<Lexical::Accessor> |
3574
|
|
|
|
|
|
|
into each class. MooX::Pression does not, but thanks to how namespacing |
3575
|
|
|
|
|
|
|
works, it only needs to be imported once if you want to use it. |
3576
|
|
|
|
|
|
|
|
3577
|
|
|
|
|
|
|
package MyApp { |
3578
|
|
|
|
|
|
|
use MooX::Pression; |
3579
|
|
|
|
|
|
|
use Lexical::Accessor; |
3580
|
|
|
|
|
|
|
|
3581
|
|
|
|
|
|
|
class Foo { |
3582
|
|
|
|
|
|
|
my $identifier = lexical_has identifier => ( |
3583
|
|
|
|
|
|
|
is => rw, |
3584
|
|
|
|
|
|
|
isa => Int, |
3585
|
|
|
|
|
|
|
default => sub { 0 }, |
3586
|
|
|
|
|
|
|
); |
3587
|
|
|
|
|
|
|
|
3588
|
|
|
|
|
|
|
method some_method () { |
3589
|
|
|
|
|
|
|
$self->$identifier( 123 ); # set identifier |
3590
|
|
|
|
|
|
|
...; |
3591
|
|
|
|
|
|
|
return $self->$identifier; # get identifier |
3592
|
|
|
|
|
|
|
} |
3593
|
|
|
|
|
|
|
} |
3594
|
|
|
|
|
|
|
} |
3595
|
|
|
|
|
|
|
|
3596
|
|
|
|
|
|
|
Lexical accessors give you true private object attributes. |
3597
|
|
|
|
|
|
|
|
3598
|
|
|
|
|
|
|
=head3 Factories |
3599
|
|
|
|
|
|
|
|
3600
|
|
|
|
|
|
|
MooX::Pression puts an emphasis on having a factory package for instantiating |
3601
|
|
|
|
|
|
|
objects. Moops didn't have anything similar. |
3602
|
|
|
|
|
|
|
|
3603
|
|
|
|
|
|
|
=head3 C<augment> and C<override> |
3604
|
|
|
|
|
|
|
|
3605
|
|
|
|
|
|
|
These are L<Moose> method modifiers that are not implemented by L<Moo>. |
3606
|
|
|
|
|
|
|
Moops allows you to use these in Moose and Mouse classes, but not Moo |
3607
|
|
|
|
|
|
|
classes. MooX::Pression simply doesn't support them. |
3608
|
|
|
|
|
|
|
|
3609
|
|
|
|
|
|
|
=head3 Type Libraries |
3610
|
|
|
|
|
|
|
|
3611
|
|
|
|
|
|
|
Moops allowed you to declare multiple type libraries, define type |
3612
|
|
|
|
|
|
|
constraints in each, and specify for each class and role which type |
3613
|
|
|
|
|
|
|
libraries you want it to use. |
3614
|
|
|
|
|
|
|
|
3615
|
|
|
|
|
|
|
MooX::Pression automatically creates a single type library for all |
3616
|
|
|
|
|
|
|
your classes and roles within a module to use, and automatically |
3617
|
|
|
|
|
|
|
populates it with the types it thinks you might want. |
3618
|
|
|
|
|
|
|
|
3619
|
|
|
|
|
|
|
If you need to use other type constraints: |
3620
|
|
|
|
|
|
|
|
3621
|
|
|
|
|
|
|
package MyApp { |
3622
|
|
|
|
|
|
|
use MooX::Pression; |
3623
|
|
|
|
|
|
|
# Just import types into the factory package! |
3624
|
|
|
|
|
|
|
use Types::Path::Tiny qw( Path ); |
3625
|
|
|
|
|
|
|
|
3626
|
|
|
|
|
|
|
class DataSource { |
3627
|
|
|
|
|
|
|
has file => ( type => Path ); |
3628
|
|
|
|
|
|
|
|
3629
|
|
|
|
|
|
|
method set_file ( Path $file ) { |
3630
|
|
|
|
|
|
|
$self->file( $file ); |
3631
|
|
|
|
|
|
|
} |
3632
|
|
|
|
|
|
|
} |
3633
|
|
|
|
|
|
|
} |
3634
|
|
|
|
|
|
|
|
3635
|
|
|
|
|
|
|
my $ds = MyApp->new_datasource; |
3636
|
|
|
|
|
|
|
$ds->set_file('blah.txt'); # coerce Str to Path |
3637
|
|
|
|
|
|
|
print $ds->file->slurp_utf8; |
3638
|
|
|
|
|
|
|
|
3639
|
|
|
|
|
|
|
=head3 Constants |
3640
|
|
|
|
|
|
|
|
3641
|
|
|
|
|
|
|
Moops: |
3642
|
|
|
|
|
|
|
|
3643
|
|
|
|
|
|
|
class Foo { |
3644
|
|
|
|
|
|
|
define PI = 3.2; |
3645
|
|
|
|
|
|
|
} |
3646
|
|
|
|
|
|
|
|
3647
|
|
|
|
|
|
|
MooX::Pression: |
3648
|
|
|
|
|
|
|
|
3649
|
|
|
|
|
|
|
class Foo { |
3650
|
|
|
|
|
|
|
constant PI = 3.2; |
3651
|
|
|
|
|
|
|
} |
3652
|
|
|
|
|
|
|
|
3653
|
|
|
|
|
|
|
=head3 Parameterizable classes and roles |
3654
|
|
|
|
|
|
|
|
3655
|
|
|
|
|
|
|
These were always on my todo list for Moops; I doubt they'll ever be done. |
3656
|
|
|
|
|
|
|
They work nicely in MooX::Pression though. |
3657
|
|
|
|
|
|
|
|
3658
|
|
|
|
|
|
|
=head1 BUGS |
3659
|
|
|
|
|
|
|
|
3660
|
|
|
|
|
|
|
Please report any bugs to |
3661
|
|
|
|
|
|
|
L<http://rt.cpan.org/Dist/Display.html?Queue=MooX-Pression>. |
3662
|
|
|
|
|
|
|
|
3663
|
|
|
|
|
|
|
=head1 TODO |
3664
|
|
|
|
|
|
|
|
3665
|
|
|
|
|
|
|
=head2 Plugin system |
3666
|
|
|
|
|
|
|
|
3667
|
|
|
|
|
|
|
MooX::Pression can often load MooX/MouseX/MooseX plugins and work |
3668
|
|
|
|
|
|
|
fine with them, but some things won't work, like plugins that rely on |
3669
|
|
|
|
|
|
|
being able to wrap C<has>. So it would be nice to have a plugin system |
3670
|
|
|
|
|
|
|
that extensions can hook into. |
3671
|
|
|
|
|
|
|
|
3672
|
|
|
|
|
|
|
If you're interested in extending MooX::Pression, file a bug report about |
3673
|
|
|
|
|
|
|
it and let's have a conversation about the best way for that to happen. |
3674
|
|
|
|
|
|
|
|
3675
|
|
|
|
|
|
|
=head1 SEE ALSO |
3676
|
|
|
|
|
|
|
|
3677
|
|
|
|
|
|
|
Less magic version: |
3678
|
|
|
|
|
|
|
L<MooX::Press>, L<portable::loader>. |
3679
|
|
|
|
|
|
|
|
3680
|
|
|
|
|
|
|
Important underlying technologies: |
3681
|
|
|
|
|
|
|
L<Moo>, L<Type::Tiny::Manual>. |
3682
|
|
|
|
|
|
|
|
3683
|
|
|
|
|
|
|
Similar modules: |
3684
|
|
|
|
|
|
|
L<Moops>, L<Kavorka>, L<Dios>, L<MooseX::Declare>. |
3685
|
|
|
|
|
|
|
|
3686
|
|
|
|
|
|
|
=head1 AUTHOR |
3687
|
|
|
|
|
|
|
|
3688
|
|
|
|
|
|
|
Toby Inkster E<lt>tobyink@cpan.orgE<gt>. |
3689
|
|
|
|
|
|
|
|
3690
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENCE |
3691
|
|
|
|
|
|
|
|
3692
|
|
|
|
|
|
|
This software is copyright (c) 2020 by Toby Inkster. |
3693
|
|
|
|
|
|
|
|
3694
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
3695
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
3696
|
|
|
|
|
|
|
|
3697
|
|
|
|
|
|
|
=head1 DISCLAIMER OF WARRANTIES |
3698
|
|
|
|
|
|
|
|
3699
|
|
|
|
|
|
|
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED |
3700
|
|
|
|
|
|
|
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF |
3701
|
|
|
|
|
|
|
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. |
3702
|
|
|
|
|
|
|
|