File Coverage

blib/lib/MooX/Pression.pm
Criterion Covered Total %
statement 501 630 79.5
branch 169 312 54.1
condition 50 95 52.6
subroutine 65 77 84.4
pod 4 6 66.6
total 789 1120 70.4


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