File Coverage

blib/lib/Zydeco.pm
Criterion Covered Total %
statement 774 892 86.7
branch 316 502 62.9
condition 98 161 60.8
subroutine 107 116 92.2
pod 4 6 66.6
total 1299 1677 77.4


line stmt bran cond sub pod time code
1 51     51   2560876 use 5.014;
  51         411  
2 51     39   2196 use strict;
  39         163  
  39         748  
3 39     37   1250 use warnings;
  37         118  
  37         1021  
4 37     35   1156 use B ();
  35         123  
  35         599  
5 35     35   769 use Carp ();
  35         104  
  35         589  
6 35     32   14682 use Import::Into ();
  32         79062  
  32         886  
7 32     31   25217 use MooX::Press 0.048 ();
  31         4734018  
  31         1244  
8 31     31   13828 use MooX::Press::Keywords ();
  31         3414057  
  31         910  
9 31     31   17164 use Syntax::Keyword::Try ();
  31         28698  
  31         814  
10 31     31   331 use feature ();
  31         70  
  31         1426  
11              
12             package Zydeco;
13              
14             our $AUTHORITY = 'cpan:TOBYINK';
15             our $VERSION = '0.613';
16              
17 31     31   13647 use Keyword::Simple ();
  31         71565  
  31         768  
18 31     31   24676 use PPR;
  31         1022546  
  31         1368  
19 31     31   449 use B::Hooks::EndOfScope;
  31         91  
  31         401  
20 31     31   18789 use Exporter::Shiny our @EXPORT = qw( version authority overload );
  31         13112  
  31         258  
21 31     31   15124 use Devel::StrictMode qw(STRICT);
  31         11655  
  31         1944  
22 31     31   335 use Types::Standard qw( is_HashRef is_CodeRef is_Str );
  31         71  
  31         304  
23              
24             my $decomment = sub {
25             require Carp;
26             Carp::carp("Cannot remove comments within a type constraint; please upgrade perl");
27             return $_[0];
28             };
29             $decomment = \&PPR::decomment if $] >= 5.016;
30              
31             BEGIN {
32             package Zydeco::_Gather;
33 31     31   67151 my %gather;
34             my %stack;
35             sub _already {
36 39     39   133 my ($me, $caller) = @_;
37 39         318 !!$gather{$me}{$caller};
38             }
39             sub _predeclare {
40 88     88   349 my ($me, $opts, $kind, $pkg, $pkgopts) = @_;
41             # Figure out type name
42 88 100       466 return if $kind =~ /role_generator/;
43 84         1271 my %opts = (%$opts, %$pkgopts);
44 84   100     1246 my $qname = 'MooX::Press'->qualify_name($pkg, $opts{'prefix'}, $opts{'extends'}//$opts{'_stack'}[-1]);
45            
46 84 100       1826 if ($kind =~ /class_generator/) {
47             my $typename1 = $opts{'class_type_name'}
48 5   33     169 || sprintf('%sClass', 'MooX::Press'->type_name($qname, $opts{'prefix'}));
49             my $typename2 = $opts{'instance_type_name'}
50 5   33     147 || sprintf('%sInstance', 'MooX::Press'->type_name($qname, $opts{'prefix'}));
51 5         95 'Zydeco'->_predeclare($opts{'caller'}, $opts{'type_library'}, $typename1, $typename2);
52             }
53             else {
54 80   66     642 my $typename = $opts{'type_name'} || 'MooX::Press'->type_name($qname, $opts{'prefix'});
55 79         2268 'Zydeco'->_predeclare($opts{'caller'}, $opts{'type_library'}, $typename);
56             }
57             }
58             sub import {
59 337     338   12436 my ($me, $action, $caller) = (shift, shift, scalar caller);
60 337 100       1828 if ($action eq -gather) {
    100          
    100          
    50          
61 125         480 while (@_) {
62 391         890 my ($k, $v) = splice @_, 0, 2;
63 391 100       1623 if (my ($kind,$pkg) = ($k =~ /^(class|role|class_generator|role_generator):(.+)$/)) {
64 87 50       203 if ( my @stack = @{ $stack{$me}{$caller}||[] } ) {
  87 50       644  
65 87 50       332 pop @stack if $stack[-1] eq $pkg;
66 87 100       316 if (@stack) {
67 25         58 $v->{_stack} = \@stack;
68 25         71 $kind = '_defer_'.$kind;
69             }
70             }
71 87   100     203 push @{ $gather{$me}{$caller}{$kind}||=[] }, $pkg, $v;
  87         655  
72 87         434 $me->_predeclare( $gather{$me}{$caller}, $kind, $pkg, $v );
73             }
74             else {
75 304         834 $gather{$me}{$caller}{$k} = $v;
76             }
77             }
78             }
79             elsif ($action eq -go) {
80 38 50       216 if ($gather{$me}{$caller}{'_defer_role'}) {
81 0         0 require Carp;
82 0         0 Carp::croak('Nested roles are not supported');
83             }
84 38 50       182 if ($gather{$me}{$caller}{'_defer_role_generator'}) {
85 0         0 require Carp;
86 0         0 Carp::croak('Nested role generators are not supported');
87             }
88 38 100       176 if ($gather{$me}{$caller}{'_defer_class_generator'}) {
89 1   50     11 $me->_undefer_class_generators($gather{$me}{$caller}{'class_generator'}||=[], delete $gather{$me}{$caller}{'_defer_class_generator'});
90             }
91 38 100       162 if ($gather{$me}{$caller}{'_defer_class'}) {
92 5         34 $me->_undefer_classes($gather{$me}{$caller}{'class'}, delete $gather{$me}{$caller}{'_defer_class'});
93             }
94            
95 35 50       169 if ($gather{$me}{$caller}{debug}) {
96 0         0 require Data::Dumper;
97 0         0 warn Data::Dumper::Dumper($gather{$me}{$caller});
98             }
99            
100 35         158 delete $stack{$me}{$caller};
101 35         147 @_ = ('MooX::Press' => delete $gather{$me}{$caller});
102 35         293 goto \&MooX::Press::import;
103             }
104             elsif ($action eq -parent) {
105 87   100     215 push @{ $stack{$me}{$caller}||=[] }, $_[0];
  87         6625  
106             }
107             elsif ($action eq -unparent) {
108 87         156 pop @{ $stack{$me}{$caller} };
  87         2054  
109             }
110             else {
111 0         0 die;
112             }
113             }
114             sub _undefer_classes {
115 5     5   23 my ($me, $classes, $d) = @_;
116 5 100       12 my %class_hash = @{$classes||[]};
  5         39  
117 5         11 my @deferred;
118 5         11 my $max_depth = 0;
119 5         21 while (@$d) {
120 24         57 my ($class, $spec) = splice(@$d, 0, 2);
121 24         109 $spec->{_class_name} = $class;
122 24         30 $spec->{_depth} = @{ $spec->{_stack} };
  24         51  
123 24         41 push @deferred, $spec;
124 24 100       72 $max_depth = $spec->{_depth} if $spec->{_depth} > $max_depth;
125             }
126 5         23 DEPTH: for my $depth (1 .. $max_depth) {
127 8         18 SPEC: for my $spec (@deferred) {
128 84 100       154 next SPEC unless $spec->{_depth} == $depth;
129 24         54 my $parent_key = join('|', @{$spec->{_stack}});
  24         56  
130 24         35 my $my_key = join('|', @{$spec->{_stack}}, $spec->{_class_name});
  24         49  
131 24 100       55 if (not $class_hash{$parent_key}) {
132 3         17 require Carp;
133             Carp::croak(sprintf(
134             '%s is nested in %s but %s is not a class',
135             $spec->{_class_name},
136             $spec->{_stack}[-1],
137 3         1426 $spec->{_stack}[-1],
138             ));
139             }
140 21   100     26 push @{ $class_hash{$parent_key}{subclass} ||=[] }, $spec->{_class_name}, $spec;
  21         68  
141 21         56 $class_hash{$my_key} = $spec;
142             }
143             }
144 2         6 for my $spec (@deferred) {
145 21         33 delete $spec->{_stack};
146 21         28 delete $spec->{_class_name};
147 21         37 delete $spec->{_depth};
148             }
149             }
150             sub _undefer_class_generators {
151 1     1   4 my ($me, $classes, $d) = @_;
152 1         4 while (@$d) {
153 1         4 my ($class, $spec) = splice(@$d, 0, 2);
154 1         4 my $extends = $spec->{_stack}[-1];
155 1         3 my $next = delete($spec->{code});
156             $spec->{code} = sub {
157 2     2   86459 my $got = $next->(@_);
158 2   50     23 $got->{extends} ||= [$extends];
159 2         17 $got;
160 1         8 };
161 1         3 delete $spec->{_stack};
162 1         5 push @$classes, $class, $spec;
163             }
164             }
165              
166 31         191422 $INC{'Zydeco/_Gather.pm'} = __FILE__;
167             };
168              
169             #
170             # GRAMMAR
171             #
172              
173             our $GRAMMAR = qr{
174             (?(DEFINE)
175            
176             (?<PerlKeyword>
177            
178             (?: include (?&MxpIncludeSyntax) )|
179             (?: class (?&MxpClassSyntax) )|
180             (?: abstract (?&MxpAbstractSyntax) )|
181             (?: role (?&MxpRoleSyntax) )|
182             (?: interface (?&MxpRoleSyntax) )|
183             (?: toolkit (?&MxpToolkitSyntax) )|
184             (?: begin (?&MxpHookSyntax) )|
185             (?: end (?&MxpHookSyntax) )|
186             (?: after_apply (?&MxpHookSyntax) )|
187             (?: before_apply (?&MxpHookSyntax) )|
188             (?: type_name (?&MxpTypeNameSyntax) )|
189             (?: extends (?&MxpExtendsSyntax) )|
190             (?: with (?&MxpWithSyntax) )|
191             (?: requires (?&MxpWithSyntax) )|
192             (?: has (?&MxpHasSyntax) )|
193             (?: constant (?&MxpConstantSyntax) )|
194             (?: coerce (?&MxpCoerceSyntax) )|
195             (?: method (?&MxpMethodSyntax) )|
196             (?: factory (?&MxpFactorySyntax) )|
197             (?: factory (?&MxpFactoryViaSyntax))|
198             (?: symmethod (?&MxpSymMethodSyntax) )|
199             (?: before (?&MxpModifierSyntax) )|
200             (?: after (?&MxpModifierSyntax) )|
201             (?: around (?&MxpModifierSyntax) )|
202             (?: multi (?&MxpMultiSyntax) )|
203             (?: try (?&TrySyntax) )
204             )#</PerlKeyword>
205            
206             (?<MxpSimpleIdentifier>
207            
208             (?&PerlIdentifier)|(?&PerlBlock)
209             )#</MxpSimpleIdentifier>
210            
211             (?<MxpSimpleIdentifiers>
212            
213             (?&MxpSimpleIdentifier)
214             (?:
215             (?&PerlOWS)
216             ,
217             (?&PerlOWS)
218             (?&MxpSimpleIdentifier)
219             )*
220             )#</MxpSimpleIdentifiers>
221            
222             (?<MxpDecoratedIdentifier>
223            
224             (?: \+ )? # CAPTURE:plus
225             (?: \* | \$ )? # CAPTURE:asterisk
226             (?: (?&MxpSimpleIdentifier) ) # CAPTURE:name
227             (?: \! | \? )? # CAPTURE:postfix
228             )#</MxpDecoratedIdentifier>
229            
230             (?<MxpDecoratedIdentifierSolo>
231             (?: (?&MxpDecoratedIdentifier) ) # deliberately non-capturing
232             )#</MxpDecoratedIdentifierSolo>
233            
234             (?<MxpDecoratedIdentifiers>
235            
236             (?&MxpDecoratedIdentifier)
237             (?:
238             (?&PerlOWS)
239             ,
240             (?&PerlOWS)
241             (?&MxpDecoratedIdentifier)
242             )*
243             )#</MxpDecoratedIdentifiers>
244            
245             (?<MxpSimpleTypeSpec>
246            
247             ~?(?&PerlBareword)(?&PerlAnonymousArray)?
248             )#</MxpSimpleTypeSpec>
249            
250             (?<MxpTypeSpec>
251            
252             (?&MxpSimpleTypeSpec)
253             (?:
254             (?&PerlOWS) \& (?&PerlOWS)
255             (?&MxpSimpleTypeSpec)
256             )*
257             (?:
258             (?&PerlOWS) \| (?&PerlOWS)
259             (?&MxpSimpleTypeSpec)
260             (?:
261             (?&PerlOWS) \& (?&PerlOWS)
262             (?&MxpSimpleTypeSpec)
263             )*
264             )*
265             )#</MxpTypeSpec>
266            
267             (?<MxpExtendedTypeSpec>
268            
269             (?&MxpTypeSpec)|(?&PerlBlock)
270             )#</MxpExtendedTypeSpec>
271            
272             (?<MxpSignatureVariable>
273             [\$\@\%]
274             (?&PerlIdentifier)
275             )#</MxpSignatureVariable>
276            
277             (?<MxpSignatureElement>
278            
279             (?&PerlOWS)
280             (?: (?&MxpExtendedTypeSpec))? # CAPTURE:type
281             (?&PerlOWS)
282             (?: # CAPTURE:name
283             (?&MxpSignatureVariable) | (\*(?&PerlIdentifier) | [\$\@\%] )
284             )
285             (?: # CAPTURE:postamble
286             \? | ((?&PerlOWS)=(?&PerlOWS)(?&PerlScalarExpression))
287             )?
288             )#</MxpSignatureElement>
289            
290             (?<MxpSignatureList>
291            
292             (?&MxpSignatureElement)
293             (?:
294             (?&PerlOWS)
295             ,
296             (?&PerlOWS)
297             (?&MxpSignatureElement)
298             )*
299             )#</MxpSignatureList>
300            
301             (?<MxpAttribute>
302            
303             :
304             [^\W0-9]\w*
305             (?:
306             [(]
307             [^\)]+
308             [)]
309             )?
310             )#</MxpAttribute>
311            
312             (?<MxpRoleList>
313            
314             (?&PerlOWS)
315             (?:
316             (?&PerlBlock) | (?&PerlQualifiedIdentifier)
317             )
318             (?:
319             (?:\s*\?) | (?: (?&PerlOWS) [(] (?&PerlOWS) (?&PerlList) (?&PerlOWS) [)] )
320             )?
321             (?:
322             (?&PerlOWS)
323             ,
324             (?&PerlOWS)
325             (?:
326             (?&PerlBlock) | (?&PerlQualifiedIdentifier)
327             )
328             (?:
329             (?:\s*\?) | (?: (?&PerlOWS) [(] (?&PerlOWS) (?&PerlList) (?&PerlOWS) [)] )
330             )?
331             )*
332             )#</MxpRoleList>
333            
334             (?<MxpCompactRoleList>
335            
336             (?&PerlOWS)
337             (?:
338             (?&PerlQualifiedIdentifier)
339             )
340             (?:
341             (?:\s*\?) | (?: (?&PerlOWS) [(] (?&PerlOWS) (?&PerlList) (?&PerlOWS) [)] )
342             )?
343             (?:
344             (?&PerlOWS)
345             ,
346             (?&PerlOWS)
347             (?:
348             (?&PerlQualifiedIdentifier)
349             )
350             (?:
351             (?:\s*\?) | (?: (?&PerlOWS) [(] (?&PerlOWS) (?&PerlList) (?&PerlOWS) [)] )
352             )?
353             )*
354             )#</MxpCompactRoleList>
355            
356             (?<MxpBlockLike>
357            
358             (?: (?&PerlBlock) ) |
359             (?: [=] (?&PerlOWS) (?&PerlScalarExpression) (?&PerlOWS) [;] )
360             )#</MxpBlockLike>
361            
362             (?<MxpIncludeSyntax>
363            
364             (?&PerlOWS)
365             (?: (?&PerlQualifiedIdentifier) )? # CAPTURE:name
366             (?&PerlOWS)
367             )#</MxpIncludeSyntax>
368            
369             (?<MxpClassSyntax>
370            
371             (?&PerlOWS)
372             (?: [+] )? # CAPTURE:plus
373             (?: (?&PerlQualifiedIdentifier) )? # CAPTURE:name
374             (?&PerlOWS)
375             (?:
376             (?: (?&PerlVersionNumber) ) # CAPTURE:version
377             (?&PerlOWS)
378             )?
379             (?:
380             [(]
381             (?&PerlOWS)
382             (?: # CAPTURE:sig
383             (?&MxpSignatureList)?
384             )
385             (?&PerlOWS)
386             [)]
387             )?
388             (?&PerlOWS)
389             (?:
390             (?: extends | isa | is )
391             (?&PerlOWS)
392             (?: (?&MxpCompactRoleList) ) # CAPTURE:compact_extends
393             (?&PerlOWS)
394             )?
395             (?:
396             (?: with | does )
397             (?&PerlOWS)
398             (?: (?&MxpCompactRoleList) ) # CAPTURE:compact_with
399             (?&PerlOWS)
400             )?
401             (?: (?&PerlBlock) )? # CAPTURE:block
402             (?&PerlOWS)
403             )#</MxpClassSyntax>
404            
405             (?<MxpAbstractSyntax>
406            
407             (?&PerlOWS)
408             class
409             (?&PerlOWS)
410             (?: [+] )? # CAPTURE:plus
411             (?: (?&PerlQualifiedIdentifier) )? # CAPTURE:name
412             (?&PerlOWS)
413             (?:
414             (?: (?&PerlVersionNumber) ) # CAPTURE:version
415             (?&PerlOWS)
416             )?
417             (?:
418             [(]
419             (?&PerlOWS)
420             (?: # CAPTURE:sig
421             (?&MxpSignatureList)?
422             )
423             (?&PerlOWS)
424             [)]
425             )?
426             (?&PerlOWS)
427             (?:
428             (?: extends | isa | is )
429             (?&PerlOWS)
430             (?: (?&MxpCompactRoleList) ) # CAPTURE:compact_extends
431             (?&PerlOWS)
432             )?
433             (?:
434             (?: with | does )
435             (?&PerlOWS)
436             (?: (?&MxpCompactRoleList) ) # CAPTURE:compact_with
437             (?&PerlOWS)
438             )?
439             (?: (?&PerlBlock) )? # CAPTURE:block
440             (?&PerlOWS)
441             )#</MxpAbstractSyntax>
442            
443             (?<MxpRoleSyntax>
444            
445             (?&PerlOWS)
446             (?: (?&PerlQualifiedIdentifier) )? # CAPTURE:name
447             (?&PerlOWS)
448             (?:
449             (?: (?&PerlVersionNumber) ) # CAPTURE:version
450             (?&PerlOWS)
451             )?
452             (?:
453             [(]
454             (?&PerlOWS)
455             (?: # CAPTURE:sig
456             (?&MxpSignatureList)?
457             )
458             (?&PerlOWS)
459             [)]
460             )?
461             (?&PerlOWS)
462             (?:
463             (?: with | does )
464             (?&PerlOWS)
465             (?: (?&MxpCompactRoleList) ) # CAPTURE:compact_with
466             (?&PerlOWS)
467             )?
468             (?: (?&PerlBlock) )? # CAPTURE:block
469             (?&PerlOWS)
470             )#</MxpRoleSyntax>
471            
472             (?<MxpHookSyntax>
473            
474             (?&PerlOWS)
475             (?: (?&PerlBlock) ) # CAPTURE:hook
476             (?&PerlOWS)
477             )#</MxpHookSyntax>
478            
479             (?<MxpTypeNameSyntax>
480            
481             (?&PerlOWS)
482             (?: (?&PerlIdentifier) ) # CAPTURE:name
483             (?&PerlOWS)
484             )#</MxpTypeNameSyntax>
485            
486             (?<MxpToolkitSyntax>
487            
488             (?&PerlOWS)
489             (?: (?&PerlIdentifier) ) # CAPTURE:name
490             (?&PerlOWS)
491             (?:
492             [(]
493             (?&PerlOWS)
494             (?: # CAPTURE:imports
495             (?: (?&PerlQualifiedIdentifier)|(?&PerlComma)|(?&PerlOWS) )*
496             )
497             (?&PerlOWS)
498             [)]
499             )?
500             (?&PerlOWS)
501             )#</MxpToolkitSyntax>
502            
503             (?<MxpExtendsSyntax>
504            
505             (?&PerlOWS)
506             (?: # CAPTURE:list
507             (?&MxpRoleList)
508             )
509             (?&PerlOWS)
510             )#</MxpExtendsSyntax>
511            
512             (?<MxpWithSyntax>
513            
514             (?&PerlOWS)
515             (?: # CAPTURE:list
516             (?&MxpRoleList)
517             )
518             (?&PerlOWS)
519             )#</MxpWithSyntax>
520            
521             (?<MxpRequiresSyntax>
522            
523             (?&PerlOWS)
524             (?: (?&MxpSimpleIdentifier) ) # CAPTURE:name
525             (?&PerlOWS)
526             (?:
527             [(]
528             (?&PerlOWS)
529             (?: # CAPTURE:sig
530             (?&MxpSignatureList)?
531             )
532             (?&PerlOWS)
533             [)]
534             )?
535             (?&PerlOWS)
536             )#</MxpRequiresSyntax>
537            
538             (?<MxpHasSyntax>
539            
540             (?&PerlOWS)
541             (?: (?&MxpDecoratedIdentifiers) ) # CAPTURE:name
542             (?&PerlOWS)
543             (?:
544             [(]
545             (?&PerlOWS)
546             (?: (?&PerlList) ) # CAPTURE:spec
547             (?&PerlOWS)
548             [)]
549             )?
550             (?&PerlOWS)
551             (?:
552             [=]
553             (?&PerlOWS)
554             (?: (?&PerlAssignment) ) # CAPTURE:default
555             )?
556             (?&PerlOWS)
557             )#</MxpHasSyntax>
558            
559             (?<MxpConstantSyntax>
560            
561             (?&PerlOWS)
562             (?: (?&PerlIdentifier) ) # CAPTURE:name
563             (?&PerlOWS)
564             =
565             (?&PerlOWS)
566             (?: (?&PerlExpression) ) # CAPTURE:expr
567             (?&PerlOWS)
568             )#</MxpConstantSyntax>
569            
570             (?<MxpMethodSyntax>
571            
572             (?&PerlOWS)
573             (?: \$? (?&MxpSimpleIdentifier) )? # CAPTURE:name
574             (?&PerlOWS)
575             (?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes
576             (?&PerlOWS)
577             (?:
578             [(]
579             (?&PerlOWS)
580             (?: # CAPTURE:sig
581             (?&MxpSignatureList)?
582             )
583             (?&PerlOWS)
584             [)]
585             )?
586             (?&PerlOWS)
587             (?: (?&MxpBlockLike) ) # CAPTURE:code
588             (?&PerlOWS)
589             )#</MxpMethodSyntax>
590            
591             (?<MxpSymMethodSyntax>
592            
593             (?&PerlOWS)
594             (?: \$? (?&MxpSimpleIdentifier) ) # CAPTURE:name
595             (?&PerlOWS)
596             (?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes
597             (?&PerlOWS)
598             (?:
599             [(]
600             (?&PerlOWS)
601             (?: # CAPTURE:sig
602             (?&MxpSignatureList)?
603             )
604             (?&PerlOWS)
605             [)]
606             )?
607             (?&PerlOWS)
608             (?: (?&MxpBlockLike) ) # CAPTURE:code
609             (?&PerlOWS)
610             )#</MxpSymMethodSyntax>
611            
612             (?<MxpMultiSyntax>
613            
614             (?&PerlOWS)
615             (?: method | factory ) # CAPTURE:kind
616             (?&PerlOWS)
617             (?: (?&MxpSimpleIdentifier) ) # CAPTURE:name
618             (?&PerlOWS)
619             (?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes
620             (?&PerlOWS)
621             (?:
622             [(]
623             (?&PerlOWS)
624             (?: # CAPTURE:sig
625             (?&MxpSignatureList)?
626             )
627             (?&PerlOWS)
628             [)]
629             )?
630             (?&PerlOWS)
631             (?: (?&MxpBlockLike) ) # CAPTURE:code
632             (?&PerlOWS)
633             )#</MxpMultiSyntax>
634            
635             (?<MxpModifierSyntax>
636            
637             (?&PerlOWS)
638             (?: (?&MxpSimpleIdentifiers) ) # CAPTURE:name
639             (?&PerlOWS)
640             (?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes
641             (?&PerlOWS)
642             (?:
643             [(]
644             (?&PerlOWS)
645             (?: # CAPTURE:sig
646             (?&MxpSignatureList)?
647             )
648             (?&PerlOWS)
649             [)]
650             )?
651             (?&PerlOWS)
652             (?: (?&MxpBlockLike) ) # CAPTURE:code
653             (?&PerlOWS)
654             )#</MxpModifierSyntax>
655            
656             # Easier to provide two separate patterns for `factory`
657            
658             (?<MxpFactorySyntax>
659            
660             (?&PerlOWS)
661             (?: (?&MxpSimpleIdentifier) ) # CAPTURE:name
662             (?&PerlOWS)
663             (?: ( (?&MxpAttribute) (?&PerlOWS) )+ )? # CAPTURE:attributes
664             (?&PerlOWS)
665             (?:
666             [(]
667             (?&PerlOWS)
668             (?: # CAPTURE:sig
669             (?&MxpSignatureList)?
670             )
671             (?&PerlOWS)
672             [)]
673             )?
674             (?&PerlOWS)
675             (?: (?&MxpBlockLike) ) # CAPTURE:code
676             (?&PerlOWS)
677             )#</MxpFactorySyntax>
678            
679             (?<MxpFactoryViaSyntax>
680            
681             (?&PerlOWS)
682             (?: (?&MxpSimpleIdentifier) ) # CAPTURE:name
683             (?&PerlOWS)
684             (?:
685             (?: via )
686             (?&PerlOWS)
687             (?: (?&MxpSimpleIdentifier) ) # CAPTURE:via
688             )?
689             (?&PerlOWS)
690             )#</MxpFactoryViaSyntax>
691            
692             (?<MxpCoerceSyntax>
693            
694             (?&PerlOWS)
695             (?: from )?
696             (?&PerlOWS)
697             (?: # CAPTURE:from
698             (?&MxpExtendedTypeSpec)
699             )
700             (?&PerlOWS)
701             (?: via )
702             (?&PerlOWS)
703             (?: # CAPTURE:via
704             (?&PerlBlock)|(?&PerlIdentifier)|(?&PerlString)
705             )
706             (?&PerlOWS)
707             (?: (?&MxpBlockLike) )? # CAPTURE:code
708             (?&PerlOWS)
709             )#</MxpCoerceSyntax>
710            
711             # try/catch/finally is implemented by another module
712             # but we need to be able to grok it to be able to parse
713             # blocks
714             #
715             (?<TrySyntax>
716            
717             (?&PerlOWS)
718             (?: do )?
719             (?&PerlOWS)
720             (?&PerlBlock)
721             (?:
722             (?&PerlOWS)
723             catch
724             (?&PerlOWS)
725             (?&PerlBlock)
726             )?
727             (?:
728             (?&PerlOWS)
729             finally
730             (?&PerlOWS)
731             (?&PerlBlock)
732             )?
733             (?&PerlOWS)
734             )#</TrySyntax>
735            
736             )
737             $PPR::GRAMMAR
738             }xso;
739              
740             my %_fetch_re_cache;
741             sub _fetch_re {
742 257     257   1206 my $key = "@_";
743 257         549 my $name = shift;
744 257         837 my %opts = @_;
745            
746 257   100     1220 $opts{anchor} ||= '';
747            
748 257   66     22397 $_fetch_re_cache{$key} ||= do {
749 143 50       189258 "$GRAMMAR" =~ m{<$name>(.+)</$name>}s or die "could not fetch re for $name";
750 143         2146 (my $re = $1) =~ s/\)\#$//;
751 143         1775 my @lines = split /\n/, $re;
752 143         556 for (@lines) {
753 2594 100       6380 if (my ($named_capture) = /# CAPTURE:(\w+)/) {
754 438         2427 s/\(\?\:/\(\?<$named_capture>/;
755             }
756             }
757 143         787 $re = join "\n", @lines;
758             $opts{anchor} eq 'start' ? qr/ ^ $re $GRAMMAR /xs :
759             $opts{anchor} eq 'end' ? qr/ $re $GRAMMAR $ /xs :
760 143 50       4440558 $opts{anchor} eq 'both' ? qr/ ^ $re $GRAMMAR $ /xs : qr/ $re $GRAMMAR /xs
    50          
    100          
761             }
762             }
763              
764             #
765             # HELPERS
766             #
767              
768             sub _handle_signature_list {
769 44     44   117 my $me = shift;
770 44         98 my $sig = $_[0];
771 44         125 my $seen_named = 0;
772 44         81 my $seen_pos = 0;
773 44         86 my @parsed;
774            
775             return (
776 44 100       202 0,
777             '',
778             '[]',
779             '',
780             ) if !$sig;
781            
782 39         150 while ($sig) {
783 62         280 $sig =~ s/^\s+//xs;
784 62 50       226 last if !$sig;
785            
786 62         215 push @parsed, {};
787            
788 62 100       1122854 if ($sig =~ /^((?&PerlBlock)) $GRAMMAR/xso) {
    100          
789 5         117 my $type = $1;
790 5         18 $parsed[-1]{type} = $type;
791 5         14 $parsed[-1]{type_is_block} = 1;
792 5         79 $sig =~ s/^\Q$type//xs;
793 5         55072 $sig =~ s/^((?&PerlOWS)) $GRAMMAR//xso;
794             }
795             elsif ($sig =~ /^((?&MxpTypeSpec)) $GRAMMAR/xso) {
796 48         1170 my $type = $1;
797 48 100       366 $parsed[-1]{type} = ($type =~ /#/) ? $type->$decomment : $type;
798 48         44756 $parsed[-1]{type_is_block} = 0;
799 48         837 $sig =~ s/^\Q$type//xs;
800 48         514521 $sig =~ s/^((?&PerlOWS)) $GRAMMAR//xso;
801             }
802             else {
803 9         66 $parsed[-1]{type} = 'Any';
804 9         32 $parsed[-1]{type_is_block} = 0;
805             }
806            
807 62 100       1583149 if ($sig =~ /^\*((?&PerlIdentifier)) $GRAMMAR/xso) {
    100          
    50          
808 14         53 my $name = $1;
809 14         51 $parsed[-1]{name} = $name;
810 14         34 $parsed[-1]{named} = 1;
811 14         70 $parsed[-1]{positional} = 0;
812 14         29 ++$seen_named;
813 14         191 $sig =~ s/^\*\Q$name//xs;
814 14         153261 $sig =~ s/^((?&PerlOWS)) $GRAMMAR//xso;
815             }
816             elsif ($sig =~ /^ ( [\$\@\%] ) (?: [=),?] | (?&PerlNWS) | $ ) $GRAMMAR/xso) {
817 1         6 state $dummy = 0;
818 1         7 my $name = substr($sig,0,1) . '____ZYDECO_DUMMY_VAR_' . ++$dummy;
819 1         4 $parsed[-1]{name} = $name;
820 1         4 $parsed[-1]{named} = 0;
821 1         2 $parsed[-1]{positional} = 1;
822 1         4 $sig = substr($sig, 1);
823 1         29486 $sig =~ s/^((?&PerlOWS)) $GRAMMAR//xs;
824             }
825             elsif ($sig =~ /^((?&MxpSignatureVariable)) $GRAMMAR/xso) {
826 47         392 my $name = $1;
827 47         214 $parsed[-1]{name} = $name;
828 47         207 $parsed[-1]{named} = 0;
829 47         169 $parsed[-1]{positional} = 1;
830 47         114 ++$seen_pos;
831 47         829 $sig =~ s/^\Q$name//xs;
832 47         1418507 $sig =~ s/^((?&PerlOWS)) $GRAMMAR//xs;
833             }
834            
835 62 100       655852 if ($sig =~ /^\?/) {
    100          
836 5         17 $parsed[-1]{optional} = 1;
837 5         60904 $sig =~ s/^\?((?&PerlOWS)) $GRAMMAR//xso;
838             }
839             elsif ($sig =~ /^=((?&PerlOWS))((?&PerlScalarExpression)) $GRAMMAR/xso) {
840 2         19 my ($ws, $default) = ($1, $2);
841 2         13 $parsed[-1]{default} = $default;
842            
843 2         33 $sig =~ s/^=\Q$ws$default//xs;
844 2         59579 $sig =~ s/^((?&PerlOWS)) $GRAMMAR//xso;
845            
846 2 50       389 if ($default =~ / \$ (?: class|self) /xso) {
847 0         0 require PadWalker;
848 0         0 $default = sprintf('do { my $invocants = PadWalker::peek_my(2)->{q[@invocants]}||PadWalker::peek_my(1)->{q[@invocants]}; my $self=$invocants->[-1]; my $class=ref($self)||$self; %s }', $default);
849 0         0 $parsed[-1]{default} = $default;
850             }
851             }
852            
853 62 100       5175 if ($sig) {
854 23 50       188 if ($sig =~ /^,/) {
855 23         694 $sig =~ s/^,//;
856             }
857             else {
858 0         0 require Carp;
859 0         0 Carp::croak(sprintf "Could not parse signature (%s), remaining: %s", $_[0], $sig);
860             }
861             }
862             }
863            
864 39         276 my @signature_var_list;
865 39         148 my $type_params_stuff = '[';
866            
867 39         133 my (@head, @tail);
868 39 100 100     441 if ($seen_named and $seen_pos) {
869 2   66     21 while (@parsed and $parsed[0]{positional}) {
870 4         21 push @head, shift @parsed;
871             }
872 2   66     13 while (@parsed and $parsed[-1]{positional}) {
873 2         13 unshift @tail, pop @parsed;
874             }
875 2 50       16 if (grep $_->{positional}, @parsed) {
876 0         0 require Carp;
877 0         0 Carp::croak("Signature contains an unexpected mixture of positional and named parameters");
878             }
879 2         10 for my $p (@head, @tail) {
880 6         14 my $is_optional = $p->{optional};
881 6   33     98 $is_optional ||= ($p->{type} =~ /^Optional/s);
882 6 50       34 if ($is_optional) {
    50          
    50          
883 0         0 require Carp;
884 0         0 Carp::croak("Cannot have optional positional parameter $p->{name} in signature with named parameters");
885             }
886             elsif ($p->{default}) {
887 0         0 require Carp;
888 0         0 Carp::croak("Cannot have positional parameter $p->{name} with default in signature with named parameters");
889             }
890             elsif ($p->{name} =~ /^[\@\%]/) {
891 0         0 require Carp;
892 0         0 Carp::croak("Cannot have slurpy parameter $p->{name} in signature with named parameters");
893             }
894             }
895             }
896            
897 39         615 require B;
898              
899 39         113 my $extra = '';
900 39         104 my $count = @parsed;
901 39         229 while (my $p = shift @parsed) {
902 56 100       243 $type_params_stuff .= B::perlstring($p->{name}) . ',' if $seen_named;
903 56 100       358 if ($p->{name} =~ /^[\@\%]/) {
904 3 50       86 if (@parsed) {
905 0         0 require Carp;
906 0         0 Carp::croak("Cannot have slurpy parameter $p->{name} in non-final position");
907             }
908             $extra .= sprintf(
909             'my (%s) = (@_==%d ? %s{$_[-1]} : ());',
910             $p->{name},
911             $count,
912 3         55 substr($p->{name}, 0, 1),
913             );
914 3         19 $p->{slurpy} = 1;
915 3 100       18 if ($p->{type} eq 'Any') {
916 2 100       12 $p->{type} = substr($p->{name}, 0, 1) eq '%' ? 'HashRef' : 'ArrayRef';
917             }
918             }
919             else {
920 53         176 push @signature_var_list, $p->{name};
921             }
922            
923 56 100       214 if ($p->{type_is_block}) {
924 3         18 $type_params_stuff .= sprintf('scalar(do %s)', $p->{type}) . ',';
925             }
926             else {
927 53         396 $type_params_stuff .= B::perlstring($p->{type}) . ',';
928             }
929 56 100 100     707 if (exists $p->{optional} or exists $p->{default} or $p->{slurpy}) {
      100        
930 10         35 $type_params_stuff .= '{';
931 10 100       60 $type_params_stuff .= sprintf('optional=>%d,', !!$p->{optional}) if exists $p->{optional};
932 10 100       51 $type_params_stuff .= sprintf('default=>sub{scalar(%s)},', $p->{default}) if exists $p->{default};
933 10 100       50 $type_params_stuff .= sprintf('slurpy=>%d,', !!$p->{slurpy}) if exists $p->{slurpy};
934 10         57 $type_params_stuff .= '},';
935             }
936             }
937            
938 39 100       271 @signature_var_list = '$arg' if $seen_named;
939 39         110 $type_params_stuff .= ']';
940            
941 39 100 66     259 if (@head or @tail) {
942 2         11 require Type::Params;
943 2         66 'Type::Params'->VERSION(1.009002);
944 2 100       11 my $head_stuff = join(q[,] => map { $_->{type_is_block} ? sprintf('scalar(do %s)', $_->{type}) : B::perlstring($_->{type}) } @head);
  4         33  
945 2 50       6 my $tail_stuff = join(q[,] => map { $_->{type_is_block} ? sprintf('scalar(do %s)', $_->{type}) : B::perlstring($_->{type}) } @tail);
  2         17  
946 2 50       18 my $opts = sprintf('{head=>%s,tail=>%s},', $head_stuff?"[$head_stuff]":0, $tail_stuff?"[$tail_stuff]":0);
    50          
947 2         11 substr($type_params_stuff, 1, 0) = $opts; # insert options after "["
948 2         10 unshift @signature_var_list, map $_->{name}, @head;
949 2         8 push @signature_var_list, map $_->{name}, @tail;
950             }
951            
952             return (
953 39         420 $seen_named,
954             join(',', @signature_var_list),
955             $type_params_stuff,
956             $extra,
957             );
958             }
959              
960             sub _handle_role_list {
961 29     29   95 my $me = shift;
962 29         107 my ($rolelist, $kind) = @_;
963 29         66 my @return;
964            
965 29         120 while (length $rolelist) {
966 34         143 $rolelist =~ s/^\s+//xs;
967            
968 34         78 my $prefix = '';
969 34         78 my $role = undef;
970 34         98 my $role_is_block = 0;
971 34         82 my $suffix = '';
972 34         65 my $role_params = undef;
973            
974 34 100       670019 if ($rolelist =~ /^((?&PerlBlock)) $GRAMMAR/xso) {
    50          
975 3         113 $role = $1;
976 3         9 $role_is_block = 1;
977 3         60 $rolelist =~ s/^\Q$role//xs;
978 3         43 $rolelist =~ s/^\s+//xs;
979             }
980             elsif ($rolelist =~ /^((?&PerlQualifiedIdentifier)) $GRAMMAR/xso) {
981 31         240 $role = $1;
982 31         636 $rolelist =~ s/^\Q$role//xs;
983 31         125 $rolelist =~ s/^\s+//xs;
984             }
985             else {
986 0         0 require Carp;
987 0         0 Carp::croak("Expected role name, got $rolelist");
988             }
989            
990 34 100       431572 if ($rolelist =~ /^\?/xs) {
    100          
991 8 50       41 if ($kind eq 'class') {
992 0         0 require Carp;
993 0         0 Carp::croak("Unexpected question mark suffix in class list");
994             }
995 8         15 $suffix = '?';
996 8         36 $rolelist =~ s/^\?\s*//xs;
997             }
998             elsif ($rolelist =~ /^((?&PerlOWS)(?&PerlList)(?&PerlOWS)) $GRAMMAR/xso) {
999 6         59 $role_params = $1;
1000 6         128 $rolelist =~ s/^\Q$role_params//xs;
1001 6         25 $rolelist =~ s/^\s+//xs;
1002             }
1003            
1004 34 100       2787 if ($role_is_block) {
1005 3         32 push @return, sprintf('sprintf(q(%s%%s%s), scalar(do %s))', $prefix, $suffix, $role);
1006             }
1007             else {
1008 31         344 push @return, B::perlstring("$prefix$role$suffix");
1009             }
1010 34 100       178 if ($role_params) {
1011 6         49 push @return, sprintf('[%s]', $role_params);
1012             }
1013            
1014 34         145 $rolelist =~ s/^\s+//xs;
1015 34 100       650 if (length $rolelist) {
1016 5 50       110 if ($rolelist =~ /^,/) {
1017 5         84 $rolelist =~ s/^\,\s*//;
1018             }
1019             else {
1020 0         0 require Carp;
1021 0         0 Carp::croak(sprintf "Could not parse role list (%s), remaining: %s", $_[0], $rolelist);
1022             }
1023             }
1024             }
1025            
1026 29         456 return join(",", @return);
1027             }
1028              
1029             sub _stringify_attributes {
1030 49 50   49   123 my @quoted = map sprintf(q("%s"), quotemeta(substr $_, 1)), @{ $_[1] || [] };
  49         339  
1031 49         667 sprintf '[%s]', join q[,], @quoted;
1032             }
1033              
1034             sub _handle_name_list {
1035 36     36   149 my ($me, $names) = @_;
1036 36 50       146 return unless $names;
1037            
1038 36         128 state $re = _fetch_re('MxpDecoratedIdentifierSolo');
1039 36         2631886 my @names = grep defined, ($names =~ /($re) $GRAMMAR/xg);
1040 36         13401 return @names;
1041             }
1042              
1043             my $_should_optimize = sub {
1044             my ($code, $sigvars) = @_;
1045            
1046             my %allowed = ( '$self' => undef, '$class' => undef, '$_' => undef, '@_' => undef );
1047             undef $allowed{$_} for split /\s*,\s*/, $sigvars//'';
1048            
1049             my @vars = ( $code =~ /[\$\@\%]\w+/g );
1050             foreach my $var (@vars) {
1051             next if exists $allowed{$var};
1052             return 0;
1053             }
1054             1;
1055             };
1056              
1057             my $DCTX = sprintf( 'definition_context => { file => __FILE__, line => __LINE__, package => __PACKAGE__, via => q(%s) }', __PACKAGE__ );
1058              
1059             sub _handle_factory_keyword {
1060 3     3   26 my ($me, $name, $via, $code, $has_sig, $sig, $attrs) = @_;
1061            
1062 3 100       31 my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $has_sig ? $me->_handle_signature_list($sig) : ();
1063            
1064 3         7 my $optim;
1065 3         12 for my $attr (@$attrs) {
1066 0 0       0 $optim = 1 if $attr =~ /^:optimize\b/;
1067             }
1068            
1069 3 50 66     17 if (defined $code and $code =~ /^=(.+)$/s) {
1070 0         0 $code = "{ $1 }";
1071 0   0     0 $optim ||= $_should_optimize->($code, $signature_var_list);
1072             }
1073            
1074 3 100       11 if ($via) {
1075 1 50       21 return sprintf(
    50          
1076             'q[%s]->_factory(%s, \\(%s));',
1077             $me,
1078             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1079             ($via =~ /^\{/ ? "scalar(do $via)" : B::perlstring($via)),
1080             );
1081             }
1082 2 50       7 if (!$has_sig) {
1083 0         0 my $munged_code = sprintf('sub { my ($factory, $class) = (@_); do %s }', $code);
1084 0 0       0 return sprintf(
    0          
1085             'q[%s]->_factory(%s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, optimize => %d });',
1086             $me,
1087             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1088             $DCTX,
1089             $me->_stringify_attributes($attrs),
1090             $optim ? B::perlstring($munged_code) : $munged_code,
1091             !!$optim,
1092             );
1093             }
1094 2         14 my $munged_code = sprintf('sub { my($factory,$class,%s)=(shift,shift,@_); %s; do %s }', $signature_var_list, $extra, $code);
1095 2 50       17 sprintf(
    50          
1096             'q[%s]->_factory(%s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });',
1097             $me,
1098             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1099             $DCTX,
1100             $me->_stringify_attributes($attrs),
1101             $optim ? B::perlstring($munged_code) : $munged_code,
1102             !!$signature_is_named,
1103             $type_params_stuff,
1104             !!$optim,
1105             );
1106             }
1107              
1108             sub _handle_method_keyword {
1109 32     32   121 my $me = shift;
1110 32         137 my ($kind, $name, $code, $has_sig, $sig, $attrs) = @_;
1111            
1112 32 100       171 my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $has_sig ? $me->_handle_signature_list($sig) : ();
1113            
1114 32         77 my $optim;
1115 32         145 for my $attr (@$attrs) {
1116 4 100       34 $optim = 1 if $attr =~ /^:optimize\b/;
1117             }
1118            
1119 32 50 33     284 if (defined $code and $code =~ /^=(.+)$/s) {
1120 0         0 $code = "{ $1 }";
1121 0   0     0 $optim ||= $_should_optimize->($code, $signature_var_list);
1122             }
1123            
1124 32         67 my $lex_name;
1125 32 100 100     220 if (defined $name and $name =~ /^\$(.+)$/) {
1126 1         3 $lex_name = $name;
1127             }
1128            
1129 32         83 my $inject_vars = 'my $class = ref($self)||$self';
1130 32 100       144 if ( $code =~ /\$\s*factory/ ) {
1131 1         6 $inject_vars .= '; my $factory = $self->FACTORY';
1132             }
1133            
1134 32         79 my $handler = '_can';
1135 32 100       115 if ( $kind eq 'symmethod' ) {
1136 7         13 $handler = '_symmethod';
1137             }
1138            
1139 32         63 my $return = '';
1140            
1141 32 100 100     202 if (defined $name and not defined $lex_name) {
1142 30 100       97 if ($has_sig) {
1143 17         132 my $munged_code = sprintf('sub { my($self,%s)=(shift,@_); %s; %s; do %s }', $signature_var_list, $extra, $inject_vars, $code);
1144 17 50       224 $return = sprintf(
    100          
1145             'q[%s]->%s(%s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });',
1146             $me,
1147             $handler,
1148             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1149             $DCTX,
1150             $me->_stringify_attributes($attrs),
1151             $optim ? B::perlstring($munged_code) : $munged_code,
1152             !!$signature_is_named,
1153             $type_params_stuff,
1154             !!$optim,
1155             );
1156             }
1157             else {
1158 13         91 my $munged_code = sprintf('sub { my $self = $_[0]; %s; do %s }', $inject_vars, $code);
1159 13 50       127 $return = sprintf(
    50          
1160             'q[%s]->%s(%s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, optimize => %d });',
1161             $me,
1162             $handler,
1163             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1164             $DCTX,
1165             $me->_stringify_attributes($attrs),
1166             $optim ? B::perlstring($munged_code) : $munged_code,
1167             !!$optim,
1168             );
1169             }
1170             }
1171             else {
1172 2 50       7 die if $kind eq 'symmethod';
1173            
1174 2 50       9 if ($has_sig) {
1175 2         14 my $munged_code = sprintf('sub { my($self,%s)=(shift,@_); %s; %s; do %s }', $signature_var_list, $extra, $inject_vars, $code);
1176 2 100       13 $return = sprintf(
1177             'q[%s]->wrap_coderef({ %s, attributes => %s, caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });',
1178             'MooX::Press',
1179             $DCTX,
1180             $me->_stringify_attributes($attrs),
1181             $optim ? B::perlstring($munged_code) : $munged_code,
1182             !!$signature_is_named,
1183             $type_params_stuff,
1184             !!$optim,
1185             );
1186             }
1187             else {
1188 0         0 my $munged_code = sprintf('sub { my $self = $_[0]; %s; do %s }', $inject_vars, $code);
1189 0 0       0 $return = sprintf(
1190             'q[%s]->wrap_coderef({ %s, attributes => %s, caller => __PACKAGE__, code => %s, optimize => %d });',
1191             'MooX::Press',
1192             $DCTX,
1193             $me->_stringify_attributes($attrs),
1194             $optim ? B::perlstring($munged_code) : $munged_code,
1195             !!$optim,
1196             );
1197             }
1198             }
1199            
1200 32 100       128 if ($lex_name) {
1201 1         13 return "my $lex_name = $return; &Internals::SvREADONLY(\\$lex_name, 1);";
1202             }
1203            
1204 31         192 return $return;
1205             }
1206              
1207             sub _handle_multi_keyword {
1208 12     12   45 my $me = shift;
1209 12         45 my ($kind, $name, $code, $has_sig, $sig, $attrs) = @_;
1210            
1211 12 50       59 my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $has_sig ? $me->_handle_signature_list($sig) : ();
1212            
1213 12         29 my $optim;
1214 12         31 my $extra_code = '';
1215 12         52 for my $attr (@$attrs) {
1216 1 50       6 $optim = 1 if $attr =~ /^:optimize\b/;
1217 1 50       12 if (my ($alias) = ($attr =~ /^:alias\((.+)\)$/)) {
1218 1         10 $extra_code .= sprintf('alias=>%s', B::perlstring($alias));
1219             }
1220             }
1221            
1222 12 100 66     93 if (defined $code and $code =~ /^=(.+)$/s) {
1223 4         23 $code = "{ $1 }";
1224 4   33     28 $optim ||= $_should_optimize->($code, $signature_var_list);
1225             }
1226            
1227 12         28 my $inject_vars = 'my $class = ref($self)||$self';
1228            
1229 12 50       40 if ($has_sig) {
1230 12 100       120 my $munged_code = sprintf(
1231             $kind eq 'factory'
1232             ? 'sub { my($factory,$self,%s)=(shift,shift,@_); %s; %s; do %s }'
1233             : 'sub { my($self,%s)=(shift,@_); %s; %s; do %s }',
1234             $signature_var_list,
1235             $extra,
1236             $inject_vars,
1237             $code,
1238             );
1239 12 50       115 return sprintf(
1240             'q[%s]->_multi(%s => %s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, named => %d, signature => %s, %s });',
1241             $me,
1242             $kind,
1243             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1244             $DCTX,
1245             $me->_stringify_attributes($attrs),
1246             $munged_code,
1247             !!$signature_is_named,
1248             $type_params_stuff,
1249             $extra_code,
1250             );
1251             }
1252             else {
1253 0 0       0 my $munged_code = sprintf(
1254             $kind eq 'factory'
1255             ? 'sub { my $factory = $_[0]; my $self = $_[1]; %s; do %s }'
1256             : 'sub { my $self = $_[0]; %s; do %s }',
1257             $inject_vars,
1258             $code,
1259             );
1260 0 0       0 return sprintf(
1261             'q[%s]->_multi(%s => %s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, named => 0, signature => sub { @_ }, %s });',
1262             $me,
1263             $kind,
1264             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1265             $DCTX,
1266             $me->_stringify_attributes($attrs),
1267             $munged_code,
1268             $extra_code,
1269             );
1270             }
1271             }
1272              
1273             sub _handle_modifier_keyword {
1274 3     3   17 my ($me, $kind, $names, $code, $has_sig, $sig, $attrs) = @_;
1275            
1276 3 50       14 my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $has_sig ? $me->_handle_signature_list($sig) : ();
1277            
1278 3         5 my $optim;
1279 3         15 for my $attr (@$attrs) {
1280 0 0       0 $optim = 1 if $attr =~ /^:optimize\b/;
1281             }
1282            
1283 3 100 66     30 if (defined $code and $code =~ /^=(.+)$/s) {
1284 1         7 $code = "{ $1 }";
1285 1   33     8 $optim ||= $_should_optimize->($code, $signature_var_list);
1286             }
1287            
1288 3         10 my $inject_vars = 'my $class = ref($self)||$self';
1289 3 50       14 if ( $code =~ /\$\s*factory/ ) {
1290 0         0 $inject_vars .= '; my $factory = $self->FACTORY';
1291             }
1292            
1293             # MooX::Press cannot handle optimizing method modifiers
1294 3         8 $optim = 0;
1295            
1296 3         18 my @names = $me->_handle_name_list($names);
1297            
1298             my $processed_names =
1299             join q[, ],
1300 3 50       18 map { /^\{/ ? "scalar(do $_)" : B::perlstring($_) } @names;
  5         84  
1301            
1302 3 50       52 if ($has_sig) {
    100          
1303 0         0 my $munged_code;
1304 0 0       0 if ($kind eq 'around') {
1305 0         0 $munged_code = sprintf('sub { my($next,$self,%s)=(shift,shift,@_); %s; %s; do %s }', $signature_var_list, $extra, $inject_vars, $code);
1306             }
1307             else {
1308 0         0 $munged_code = sprintf('sub { my($self,%s)=(shift,@_); %s; %s; do %s }', $signature_var_list, $extra, $inject_vars, $code);
1309             }
1310 0 0       0 sprintf(
1311             'q[%s]->_modifier(q(%s), %s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });',
1312             $me,
1313             $kind,
1314             $processed_names,
1315             $DCTX,
1316             $me->_stringify_attributes($attrs),
1317             $optim ? B::perlstring($munged_code) : $munged_code,
1318             !!$signature_is_named,
1319             $type_params_stuff,
1320             !!$optim,
1321             );
1322             }
1323             elsif ($kind eq 'around') {
1324 1         9 my $munged_code = sprintf('sub { my ($next, $self) = @_; %s; do %s }', $inject_vars, $code);
1325 1 50       9 sprintf(
1326             'q[%s]->_modifier(q(%s), %s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, optimize => %d });',
1327             $me,
1328             $kind,
1329             $processed_names,
1330             $DCTX,
1331             $me->_stringify_attributes($attrs),
1332             $optim ? B::perlstring($munged_code) : $munged_code,
1333             !!$optim,
1334             );
1335             }
1336             else {
1337 2         18 my $munged_code = sprintf('sub { my $self = $_[0]; %s; do %s }', $inject_vars, $code);
1338 2 50       113 sprintf(
1339             'q[%s]->_modifier(q(%s), %s, { %s, attributes => %s, caller => __PACKAGE__, code => %s, optimize => %d });',
1340             $me,
1341             $kind,
1342             $processed_names,
1343             $DCTX,
1344             $me->_stringify_attributes($attrs),
1345             $optim ? B::perlstring($munged_code) : $munged_code,
1346             !!$optim,
1347             );
1348             }
1349             }
1350              
1351             sub _handle_package_keyword {
1352 92     92   459 my ($me, $kind, $name, $version, $compact_extends, $compact_with, $code, $has_sig, $sig, $plus, $opts) = @_;
1353            
1354 92         215 my $compact_code = '';
1355 92 100       292 if ($compact_extends) {
1356 6         29 $compact_code .= sprintf('q[%s]->_extends(%s);', $me, $me->_handle_role_list($compact_extends, 'class'));
1357             }
1358 92 100       276 if ($compact_with) {
1359 6         45 $compact_code .= sprintf('q[%s]->_with(%s);', $me, $me->_handle_role_list($compact_with, 'role'));
1360             }
1361 92 100       299 if ($version) {
1362 1 50       13 $compact_code .= sprintf('%s::version(%s);', $me, $version =~ /^[0-9]/ ? B::perlstring($version) : $version);
1363             }
1364            
1365 92 100       609 if ($kind eq 'abstract') {
    50          
    100          
1366 1         2 $kind = 'class';
1367 1         6 $code = "{ q[$me]->_abstract(1); $compact_code $code }";
1368             }
1369             elsif ($kind eq 'interface') {
1370 0         0 $kind = 'role';
1371 0         0 $code = "{ q[$me]->_interface(1); $compact_code $code }";
1372             }
1373             elsif (length $compact_code) {
1374 9         53 $code = "{ $compact_code $code }";
1375             }
1376            
1377 92 100 100     689 if ($name and $has_sig) {
    100          
    100          
1378 8         46 my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig);
1379 8         86 my $munged_code = sprintf('sub { q(%s)->_package_callback(sub { my ($generator,%s)=(shift,@_); %s; do %s }, @_) }', $me, $signature_var_list, $extra, $code);
1380 8         185 return sprintf(
1381             'use Zydeco::_Gather -parent => %s; use Zydeco::_Gather -gather, %s => { code => %s, named => %d, signature => %s }; use Zydeco::_Gather -unparent;',
1382             B::perlstring("$plus$name"),
1383             B::perlstring("$kind\_generator:$plus$name"),
1384             $munged_code,
1385             !!$signature_is_named,
1386             $type_params_stuff,
1387             );
1388             }
1389             elsif ($has_sig) {
1390 1         7 my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig);
1391 1         20 my $munged_code = sprintf('sub { q(%s)->_package_callback(sub { my ($generator,%s)=(shift,@_); %s; do %s }, @_) }', $me, $signature_var_list, $extra, $code);
1392             return sprintf(
1393             'q[%s]->anonymous_generator(%s => { code => %s, named => %d, signature => %s }, toolkit => %s, prefix => %s, factory_package => %s, type_library => %s)',
1394             $me,
1395             $kind,
1396             $munged_code,
1397             !!$signature_is_named,
1398             $type_params_stuff,
1399             B::perlstring($opts->{toolkit}||'Moo'),
1400             B::perlstring($opts->{prefix}),
1401             B::perlstring($opts->{factory_package}),
1402 1   50     35 B::perlstring($opts->{type_library}),
1403             );
1404             }
1405             elsif ($name) {
1406 79 50       1590 return $code
1407             ? sprintf(
1408             'use Zydeco::_Gather -parent => %s; use Zydeco::_Gather -gather, %s => q[%s]->_package_callback(%s, sub %s); use Zydeco::_Gather -unparent;',
1409             B::perlstring("$plus$name"),
1410             B::perlstring("$kind:$plus$name"),
1411             $me,
1412             $DCTX,
1413             $code,
1414             )
1415             : sprintf(
1416             'use Zydeco::_Gather -gather, %s => {};',
1417             B::perlstring("$kind:$plus$name"),
1418             );
1419             }
1420             else {
1421 4   50     13 $code ||= '{}';
1422             return sprintf(
1423             'q[%s]->anonymous_package(%s => sub { do %s }, toolkit => %s, prefix => %s, factory_package => %s, type_library => %s, %s)',
1424             $me,
1425             $kind,
1426             $code,
1427             B::perlstring($opts->{toolkit}||'Moo'),
1428             B::perlstring($opts->{prefix}),
1429             B::perlstring($opts->{factory_package}),
1430 4   50     87 B::perlstring($opts->{type_library}),
1431             $DCTX,
1432             );
1433             }
1434             }
1435              
1436             sub _handle_has_keyword {
1437 33     33   163 my ($me, $names, $rawspec, $default) = @_;
1438            
1439 33 100       154 $rawspec = '()' if !defined $rawspec;
1440            
1441 33 50 66     289 if (defined $default and $default =~ /\$\s*(?:self|class|factory)/) {
    100          
1442 0         0 my $inject_vars = 'my $class = ref($self)||$self';
1443 0 0       0 if ( $default =~ /\$\s*factory/ ) {
1444 0         0 $inject_vars .= '; my $factory = $self->FACTORY';
1445             }
1446 0         0 $rawspec = "lazy => !!1, default => sub { my \$self = \$_[0]; $inject_vars; $default }, $rawspec";
1447             }
1448             elsif (defined $default) {
1449 6         34 $rawspec = "default => sub { $default }, $rawspec";
1450             }
1451            
1452 33         309 my @names = $me->_handle_name_list($names);
1453            
1454 33         211 my @r;
1455             my @make_read_only;
1456 33         228 for my $name (@names) {
1457 37         170 $name =~ s/^\+\*/+/;
1458 37         112 $name =~ s/^\*//;
1459            
1460 37 100       220 if ($name =~ /^\$(.+)$/) {
1461 1         8 my $display_name = $1;
1462 1         8 unshift @r, "my $name";
1463 1 50       23 push @r, sprintf(
1464             'q[%s]->_has(%s, %s, is => "private", accessor => \\%s, %s)',
1465             $me,
1466             ($display_name =~ /^\{/) ? "scalar(do $display_name)" : B::perlstring($display_name),
1467             $DCTX,
1468             $name,
1469             $rawspec,
1470             );
1471 1         5 push @make_read_only, $name;
1472             }
1473             else {
1474 36 100       847 push @r, sprintf(
1475             'q[%s]->_has(%s, %s, %s)',
1476             $me,
1477             ($name =~ /^\{/) ? "scalar(do $name)" : B::perlstring($name),
1478             $DCTX,
1479             $rawspec,
1480             );
1481             }
1482             }
1483            
1484 33 100       174 if (@make_read_only) {
1485 1         13 push @r, sprintf(
1486             'q[%s]->_end(sub { &Internals::SvREADONLY($_, 1) for %s; })',
1487             $me,
1488             join(q{,}, map("\\$_", @make_read_only)),
1489             );
1490             }
1491            
1492 33         539 join ";", @r;
1493             }
1494              
1495             sub _handle_requires_keyword {
1496 3     3   12 my ($me, $name, $has_sig, $sig) = @_;
1497 3 50       43 my $r1 = sprintf(
1498             'q[%s]->_requires(%s);',
1499             $me,
1500             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1501             );
1502 3         8 my $r2 = '';
1503 3 100       14 if (STRICT and $has_sig) {
1504 2         9 my ($signature_is_named, $signature_var_list, $type_params_stuff, $extra) = $me->_handle_signature_list($sig);
1505 2 50       31 $r2 = sprintf(
1506             'q[%s]->_modifier(q(around), %s, { caller => __PACKAGE__, code => %s, named => %d, signature => %s, optimize => %d });',
1507             $me,
1508             ($name =~ /^\{/ ? "scalar(do $name)" : B::perlstring($name)),
1509             'sub { my $next = shift; goto $next }',
1510             !!$signature_is_named,
1511             $type_params_stuff,
1512             1,
1513             );
1514             }
1515 3         20 "$r1$r2";
1516             }
1517              
1518             sub _syntax_error {
1519 0     0   0 require Carp;
1520 0 0       0 if (ref $_[-1]) {
1521 0         0 my $ref = pop;
1522 0         0 my ($me, $kind, @poss) = @_;
1523 0         0 Carp::croak(
1524             "Unexpected syntax in $kind.\n" .
1525             "Expected:\n" .
1526             join("", map "\t$_\n", @poss) .
1527             "Got:\n" .
1528             "\t" . substr($$ref, 0, 32)
1529             );
1530             }
1531             else {
1532 0         0 my ($me, $kind, $msg) = @_;
1533 0         0 Carp::croak("Unexpected syntax in $kind.\n" . $msg);
1534             }
1535             }
1536              
1537             my $owed = 0;
1538             sub _inject {
1539 212     212   940 my ($me, $ref, $trim_length, $new_code, $pad_at_end) = @_;
1540 212   100     993 $pad_at_end ||= 0;
1541            
1542 212         1612 my @orig_lines = split /\n/, substr($$ref, 0, $trim_length), -1;
1543 212         958 my @new_lines = split /\n/, $new_code, -1;
1544            
1545 212 100       1042 if ($#orig_lines > $#new_lines) {
    100          
1546 119         343 my $diff = $#orig_lines - $#new_lines;
1547 119 50 33     666 if ($owed and $owed > $diff) {
    50          
1548 0         0 $owed -= $diff;
1549 0         0 $diff = 0;
1550             }
1551             elsif ($owed) {
1552 0         0 $diff -= $owed;
1553 0         0 $owed = 0;
1554             }
1555 119         387 my $prefix = "\n" x $diff;
1556 119 100       508 $new_code = $pad_at_end ? $new_code.$prefix : $prefix.$new_code;
1557             }
1558             elsif ($#orig_lines < $#new_lines) {
1559 1         4 $owed += ($#new_lines - $#orig_lines);
1560             }
1561            
1562 212         28199 substr $$ref, 0, $trim_length, $new_code;
1563             }
1564              
1565             #
1566             # KEYWORDS/UTILITIES
1567             #
1568              
1569             my @EXPORTABLES = qw(
1570             -booleans
1571             -privacy
1572             -util
1573             -types
1574             -is
1575             -assert
1576             -features
1577             try
1578             class abstract role interface
1579             begin end before_apply after_apply
1580             include toolkit extends with requires
1581             has constant method symmethod multi factory before after around
1582             type_name coerce
1583             version authority overload
1584             );
1585              
1586             sub unimport {
1587 0     0   0 Keyword::Simple::undefine($_) for qw<
1588             class abstract role interface
1589             begin end before_apply after_apply
1590             include toolkit extends with requires
1591             has constant method symmethod multi factory before after around
1592             type_name coerce
1593             version authority overload
1594             >;
1595 0         0 goto \&Exporter::Tiny::unimport;
1596             }
1597              
1598             sub _predeclare {
1599 83     83   350 my ($me, $caller, $types, @names) = @_;
1600            
1601 83         239 for my $name (@names) {
1602 87         155 my $cached;
1603             my $T = sub () {
1604 1 50 33 1   2033 if ( !$cached or $cached->isa('Type::Tiny::_DeclaredType') ) {
1605 1   33     23 my $got = $types->can('get_type') && $types->get_type($name);
1606 1 50       81 $cached = $got if $got;
1607 1   33     8 $cached ||= 'Type::Tiny::_DeclaredType'->new(
1608             name => $name,
1609             library => $types,
1610             );
1611             }
1612 1         10 $cached;
1613 87         515 };
1614 87 50   29   8437 eval qq{
  29         269  
  29         64  
  29         3859  
1615             package Zydeco; # allow namespace::autoclean to clean them
1616             no warnings 'redefine';
1617             *$caller\::$name = \$T;
1618             *$caller\::is_$name = sub (\$) { \$T->()->check(\@_) };
1619             *$caller\::assert_$name = sub (\$) { \$T->()->assert_return(\@_) };
1620             1;
1621             } or die($@);
1622             }
1623             }
1624              
1625             sub import {
1626 31     31   329 no warnings 'closure';
  31         174  
  31         35236  
1627 38     38   26712 my ($me, %opts) = (shift, @_);
1628 38   33     485 my $caller = ($opts{caller} ||= caller);
1629            
1630 38 50       230 if ('Zydeco::_Gather'->_already($caller)) {
1631 0         0 require Carp;
1632 0         0 Carp::croak("Zydeco is already in scope");
1633             }
1634            
1635 38         370 require MooX::Press;
1636 38         307 'MooX::Press'->_apply_default_options(\%opts);
1637            
1638 38 50       3072 my %want = map +($_ => 1), @{ $opts{keywords} || \@EXPORTABLES };
  38         1382  
1639            
1640             # Optionally export wrapper subs for pre-declared types
1641             #
1642 38 50       214 if ($opts{declare}) {
1643 0         0 my $types = $opts{type_library};
1644 0         0 $me->_predeclare($caller, $types, @{ $opts{declare} });
  0         0  
1645             }
1646            
1647             # Export utility stuff
1648             #
1649 38         469 Zydeco::_Gather->import::into($caller, -gather => %opts);
1650 38         494 strict->import::into($caller);
1651 38         6795 warnings->import::into($caller);
1652             MooX::Press::Keywords->import::into($caller, $_)
1653 38         7103 for grep $want{$_}, qw(-booleans -privacy -util);
1654 38 50       154887 Syntax::Keyword::Try->import::into($caller) if $want{try};
1655 38 50       9422 if ($] >= 5.018) {
    0          
1656             feature->import::into($caller, qw( say state unicode_strings unicode_eval evalbytes current_sub fc ))
1657 38 50       462 if $want{-features};
1658             }
1659             elsif ($] >= 5.014) {
1660             feature->import::into($caller, qw( say state unicode_strings ))
1661 0 0       0 if $want{-features};
1662             }
1663 38         11787 my @libs = qw/ Types::Standard Types::Common::Numeric Types::Common::String /;
1664 38 100       461 push @libs, $opts{type_library} if $opts{type_library}->isa('Type::Library');
1665 38         121 for my $library (@libs) {
1666             $library->import::into($caller, { replace => 1 }, $_)
1667 115         798300 for grep $want{$_}, qw( -types -is -assert );
1668             }
1669            
1670             # `include` keyword
1671             #
1672             Keyword::Simple::define include => sub {
1673 2     2   8 my $ref = shift;
1674            
1675 2 50       21 $$ref =~ _fetch_re('MxpIncludeSyntax', anchor => 'start') or $me->_syntax_error(
1676             'include directive',
1677             'include <name>',
1678             $ref,
1679             );
1680            
1681 2         62 my ($pos, $name) = ($+[0], $+{name});
1682 2         17 my $qualified = 'MooX::Press'->qualify_name($name, $opts{prefix});
1683 2         60 $me->_inject($ref, $pos, sprintf('BEGIN { eval(q[%s]->_include(%s)) or die($@) };', $me, B::perlstring($qualified)));
1684 38 50       204216 } if $want{include};
1685              
1686             # `class` keyword
1687             #
1688             Keyword::Simple::define class => sub {
1689 75     75   11271 my $ref = shift;
1690            
1691             # my $re = _fetch_re('MxpCompactRoleList', anchor => 'start');
1692             # my @r = "Foo with Bar" =~ /($re)/;
1693             # use Data::Dumper;
1694             # die Dumper($r[0], $re);
1695              
1696 75 50       587 $$ref =~ _fetch_re('MxpClassSyntax', anchor => 'start') or $me->_syntax_error(
1697             'class declaration',
1698             'class <name> (<signature>) { <block> }',
1699             'class <name> { <block> }',
1700             'class <name>',
1701             'class (<signature>) { <block> }',
1702             'class { <block> }',
1703             'class;',
1704             $ref,
1705             );
1706            
1707 75         140063 my ($pos, $plus, $name, $version, $sig, $compact_extends, $compact_with, $block) = ($+[0], $+{plus}, $+{name}, $+{version}, $+{sig}, $+{compact_extends}, $+{compact_with}, $+{block});
1708 75         622 my $has_sig = !!exists $+{sig};
1709 75   100     588 $plus ||= '';
1710 75   100     285 $block ||= '{}';
1711            
1712 75         526 $me->_inject($ref, $pos, $me->_handle_package_keyword(class => $name, $version, $compact_extends, $compact_with, $block, $has_sig, $sig, $plus, \%opts), 1);
1713 38 50       1420 } if $want{class};
1714              
1715             Keyword::Simple::define abstract => sub {
1716 1     1   476 my $ref = shift;
1717            
1718 1 50       19 $$ref =~ _fetch_re('MxpAbstractSyntax', anchor => 'start') or $me->_syntax_error(
1719             'abstract class declaration',
1720             'abstract class <name> (<signature>) { <block> }',
1721             'abstract class <name> { <block> }',
1722             'abstract class <name>',
1723             'abstract class (<signature>) { <block> }',
1724             'abstract class { <block> }',
1725             'abstract class;',
1726             $ref,
1727             );
1728            
1729 1         42 my ($pos, $plus, $name, $version, $sig, $compact_extends, $compact_with, $block) = ($+[0], $+{plus}, $+{name}, $+{version}, $+{sig}, $+{compact_extends}, $+{compact_with},$+{block});
1730 1         10 my $has_sig = !!exists $+{sig};
1731 1   50     9 $plus ||= '';
1732 1   50     8 $block ||= '{}';
1733            
1734 1         11 $me->_inject($ref, $pos, $me->_handle_package_keyword(abstract => $name, $version, $compact_extends, $compact_with, $block, $has_sig, $sig, $plus, \%opts), 1);
1735 38 50       1050 } if $want{abstract};
1736              
1737 38         667 for my $kw (qw/ role interface /) {
1738             Keyword::Simple::define $kw => sub {
1739 16     16   2331 my $ref = shift;
1740            
1741 16 50       109 $$ref =~ _fetch_re('MxpRoleSyntax', anchor => 'start') or $me->_syntax_error(
1742             "$kw declaration",
1743             "$kw <name> (<signature>) { <block> }",
1744             "$kw <name> { <block> }",
1745             "$kw <name>",
1746             "$kw (<signature>) { <block> }",
1747             "$kw { <block> }",
1748             "$kw;",
1749             $ref,
1750             );
1751            
1752 16         29391 my ($pos, $name, $version, $sig, $compact_extends, $compact_with, $block) = ($+[0], $+{name}, $+{version}, $+{sig}, $+{compact_extends}, $+{compact_with}, $+{block});
1753 16         142 my $has_sig = !!exists $+{sig};
1754 16   50     73 $block ||= '{}';
1755            
1756 16         120 $me->_inject($ref, $pos, $me->_handle_package_keyword($kw => $name, $version, $compact_extends, $compact_with, $block, $has_sig, $sig, '', \%opts), 1);
1757 76 50       1159 } if $want{$kw};
1758             }
1759              
1760             Keyword::Simple::define toolkit => sub {
1761 0     0   0 my $ref = shift;
1762            
1763 0 0       0 $$ref =~ _fetch_re('MxpToolkitSyntax', anchor => 'start') or $me->_syntax_error(
1764             'toolkit declaration',
1765             'toolkit <toolkit> (<extensions>)',
1766             'toolkit <toolkit>;',
1767             $ref,
1768             );
1769            
1770 0         0 my ($pos, $name, $imports) = ($+[0], $+{name}, $+{imports});
1771            
1772 0 0       0 if ($imports) {
1773 0         0 my @imports = grep defined,
1774             ($imports =~ / ((?&PerlQualifiedIdentifier)|(?&PerlComma)) $GRAMMAR /xg);
1775 0         0 my @processed_imports;
1776 0         0 while (@imports) {
1777 31     31   280 no warnings 'uninitialized';
  31         167  
  31         171975  
1778 0         0 my $next = shift @imports;
1779 0 0       0 if ($next =~ /^::(.+)$/) {
    0          
1780 0         0 push @processed_imports, $1;
1781             }
1782             elsif ($next =~ /^[^\W0-9]/) {
1783 0         0 push @processed_imports, sprintf('%sX::%s', $name, $next);
1784             }
1785             else {
1786 0         0 require Carp;
1787 0         0 Carp::croak("Expected package name, got $next");
1788             }
1789 0 0       0 $imports[0] eq ',' and shift @imports;
1790             }
1791 0         0 $me->_inject($ref, $pos, sprintf('q[%s]->_toolkit(%s);', $me, join ",", map(B::perlstring($_), $name, @processed_imports)));
1792             }
1793            
1794             else {
1795 0         0 $me->_inject($ref, $pos, sprintf('q[%s]->_toolkit(%s);', $me, B::perlstring($name)));
1796             }
1797 38 50       960 } if $want{toolkit};
1798              
1799             # `begin`, `end`, `before_apply`, and `after_apply` keywords
1800             #
1801 38         877 my %injections = (
1802             begin => [ '$package,$kind', '' ],
1803             end => [ '$package,$kind', '' ],
1804             before_apply => [ '$role,$package', 'my $kind = "Role::Hooks"->is_role($package)?"role":"class";' ],
1805             after_apply => [ '$role,$package', 'my $kind = "Role::Hooks"->is_role($package)?"role":"class";' ],
1806             );
1807 38         123 for my $kw (qw/ begin end before_apply after_apply /) {
1808             Keyword::Simple::define $kw => sub {
1809 5     5   23 my $ref = shift;
1810            
1811 5 50       39 $$ref =~ _fetch_re('MxpHookSyntax', anchor => 'start') or $me->_syntax_error(
1812             "$kw hook",
1813             "$kw { <block> }",
1814             $ref,
1815             );
1816            
1817 5         12954 my ($pos, $capture) = ($+[0], $+{hook});
1818 5         58 my $inj = sprintf('q[%s]->_%s(sub { my (%s) = @_; %s; do %s });', $me, $kw, $injections{$kw}[0], $injections{$kw}[1], $capture);
1819 5         35 $me->_inject($ref, $pos, $inj);
1820 152 50       2783 } if $want{$kw};
1821             }
1822            
1823             # `type_name` keyword
1824             #
1825             Keyword::Simple::define type_name => sub {
1826 1     1   3 my $ref = shift;
1827            
1828 1 50       4 $$ref =~ _fetch_re('MxpTypeNameSyntax', anchor => 'start') or $me->_syntax_error(
1829             'type name declaration',
1830             'type_name <identifier>',
1831             $ref,
1832             );
1833            
1834 1         16 my ($pos, $capture) = ($+[0], $+{name});
1835 1         23 $me->_inject($ref, $pos, sprintf('q[%s]->_type_name(%s);', $me, B::perlstring($capture)));
1836 38 50       1022 } if $want{type_name};
1837            
1838             # `extends` keyword
1839             #
1840             Keyword::Simple::define extends => sub {
1841 6     6   27 my $ref = shift;
1842            
1843 6 50       35 $$ref =~ _fetch_re('MxpExtendsSyntax', anchor => 'start') or $me->_syntax_error(
1844             'extends declaration',
1845             'extends <classes>',
1846             $ref,
1847             );
1848            
1849 6         279 my ($pos, $capture) = ($+[0], $+{list});
1850 6         78 $me->_inject($ref, $pos, sprintf('q[%s]->_extends(%s);', $me, $me->_handle_role_list($capture, 'class')));
1851 38 50       976 } if $want{extends};
1852            
1853             # `with` keyword
1854             #
1855             Keyword::Simple::define with => sub {
1856 11     11   42 my $ref = shift;
1857            
1858 11 50       45 $$ref =~ _fetch_re('MxpWithSyntax', anchor => 'start') or $me->_syntax_error(
1859             'with declaration',
1860             'with <roles>',
1861             $ref,
1862             );
1863            
1864 11         219 my ($pos, $capture) = ($+[0], $+{list});
1865            
1866 11         107 $me->_inject($ref, $pos, sprintf('q[%s]->_with(%s);', $me, $me->_handle_role_list($capture, 'role')));
1867 38 50       985 } if $want{with};
1868            
1869             # `requires` keyword
1870             #
1871             Keyword::Simple::define requires => sub {
1872 3     3   12 my $ref = shift;
1873            
1874 3 50       15 $$ref =~ _fetch_re('MxpRequiresSyntax', anchor => 'start') or $me->_syntax_error(
1875             'requires declaration',
1876             'requires <name> (<signature>)',
1877             'requires <name>',
1878             $ref,
1879             );
1880            
1881 3         61 my ($pos, $name, $sig) = ($+[0], $+{name}, $+{sig});
1882 3         23 my $has_sig = !!exists $+{sig};
1883 3         30 $me->_inject($ref, $pos, $me->_handle_requires_keyword($name, $has_sig, $sig));
1884 38 50       960 } if $want{requires};
1885            
1886             # `has` keyword
1887             #
1888             Keyword::Simple::define has => sub {
1889 33     33   167 my $ref = shift;
1890            
1891 33 50       176 $$ref =~ _fetch_re('MxpHasSyntax', anchor => 'start') or $me->_syntax_error(
1892             'attribute declaration',
1893             'has <names> (<spec>) = <default>',
1894             'has <names> (<spec>)',
1895             'has <names> = <default>',
1896             'has <names>',
1897             $ref,
1898             );
1899            
1900 33         4917 my ($pos, $name, $spec, $default) = ($+[0], $+{name}, $+{spec}, $+{default});
1901 33         264 my $has_spec = !!exists $+{spec};
1902 33         173 my $has_default = !!exists $+{default};
1903 33 100       504 $me->_inject($ref, $pos, $me->_handle_has_keyword($name, $has_spec ? $spec : undef, $has_default ? $default : undef));
    100          
1904 38 50       1136 } if $want{has};
1905            
1906             # `constant` keyword
1907             #
1908             Keyword::Simple::define constant => sub {
1909 8     8   40 my $ref = shift;
1910            
1911 8 50       46 $$ref =~ _fetch_re('MxpConstantSyntax', anchor => 'start') or $me->_syntax_error(
1912             'constant declaration',
1913             'constant <name> = <value>',
1914             $ref,
1915             );
1916            
1917 8         223 my ($pos, $name, $expr) = ($+[0], $+{name}, $+{expr});
1918 8         193 $me->_inject($ref, $pos, sprintf('q[%s]->_constant(%s, %s);', $me, B::perlstring($name), $expr));
1919 38 50       998 } if $want{constant};
1920            
1921             # `method` keyword
1922             #
1923             Keyword::Simple::define method => sub {
1924 25     25   107 my $ref = shift;
1925            
1926 25         105 state $re_attr = _fetch_re('MxpAttribute');
1927            
1928 25 50       376 $$ref =~ _fetch_re('MxpMethodSyntax', anchor => 'start') or $me->_syntax_error(
1929             'method declaration',
1930             'method <name> <attributes> (<signature>) { <block> }',
1931             'method <name> (<signature>) { <block> }',
1932             'method <name> <attributes> { <block> }',
1933             'method <name> { <block> }',
1934             'method <attributes> (<signature>) { <block> }',
1935             'method (<signature>) { <block> }',
1936             'method <attributes> { <block> }',
1937             'method { <block> }',
1938             $ref,
1939             );
1940            
1941 25         34404 my ($pos, $name, $attributes, $sig, $code) = ($+[0], $+{name}, $+{attributes}, $+{sig}, $+{code});
1942 25         224 my $has_sig = !!exists $+{sig};
1943 25 100       83456 my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : ();
1944            
1945 25         677 $me->_inject($ref, $pos, $me->_handle_method_keyword(method => $name, $code, $has_sig, $sig, \@attrs));
1946 38 50       1428 } if $want{method};
1947              
1948             # `symmethod` keyword
1949             #
1950             Keyword::Simple::define symmethod => sub {
1951 7     7   24 my $ref = shift;
1952            
1953 7         17 state $re_attr = _fetch_re('MxpAttribute');
1954            
1955 7 50       38 $$ref =~ _fetch_re('MxpSymMethodSyntax', anchor => 'start') or $me->_syntax_error(
1956             'symmethod declaration',
1957             'symmethod <name> <attributes> (<signature>) { <block> }',
1958             'symmethod <name> (<signature>) { <block> }',
1959             'symmethod <name> <attributes> { <block> }',
1960             'symmethod <name> { <block> }',
1961             $ref,
1962             );
1963            
1964 7         5593 my ($pos, $name, $attributes, $sig, $code) = ($+[0], $+{name}, $+{attributes}, $+{sig}, $+{code});
1965 7         47 my $has_sig = !!exists $+{sig};
1966 7 100       32741 my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : ();
1967            
1968 7         257 $me->_inject($ref, $pos, $me->_handle_method_keyword(symmethod => $name, $code, $has_sig, $sig, \@attrs));
1969 38 50       1087 } if $want{symmethod};
1970              
1971             # `multi` keyword
1972             #
1973             Keyword::Simple::define multi => sub {
1974 12     12   53 my $ref = shift;
1975            
1976 12         36 state $re_attr = _fetch_re('MxpAttribute');
1977            
1978 12 50       85 $$ref =~ _fetch_re('MxpMultiSyntax', anchor => 'start') or $me->_syntax_error(
1979             'multimethod declaration',
1980             'multi method <name> <attributes> (<signature>) { <block> }',
1981             'multi method <name> (<signature>) { <block> }',
1982             'multi method <name> <attributes> { <block> }',
1983             'multi method <name> { <block> }',
1984             'multi factory <name> <attributes> (<signature>) { <block> }',
1985             'multi factory <name> (<signature>) { <block> }',
1986             'multi factory <name> <attributes> { <block> }',
1987             'multi factory <name> { <block> }',
1988             $ref,
1989             );
1990            
1991 12         6518 my ($pos, $kind, $name, $attributes, $sig, $code) = ($+[0], $+{kind}, $+{name}, $+{attributes}, $+{sig}, $+{code});
1992 12         103 my $has_sig = !!exists $+{sig};
1993 12 100       32859 my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : ();
1994            
1995 12         384 $me->_inject($ref, $pos, $me->_handle_multi_keyword($kind, $name, $code, $has_sig, $sig, \@attrs));
1996 38 50       1153 } if $want{multi};
1997              
1998             # `before`, `after`, and `around` keywords
1999             #
2000 38         866 for my $kw (qw( before after around )) {
2001             Keyword::Simple::define $kw => sub {
2002 3     3   17 my $ref = shift;
2003            
2004 3         21 state $re_attr = _fetch_re('MxpAttribute');
2005            
2006 3 50       21 $$ref =~ _fetch_re('MxpModifierSyntax', anchor => 'start') or $me->_syntax_error(
2007             "$kw method modifier declaration",
2008             "$kw <names> <attributes> (<signature>) { <block> }",
2009             "$kw <names> (<signature>) { <block> }",
2010             "$kw <names> <attributes> { <block> }",
2011             "$kw <names> { <block> }",
2012             $ref,
2013             );
2014            
2015 3         1160 my ($pos, $name, $attributes, $sig, $code) = ($+[0], $+{name}, $+{attributes}, $+{sig}, $+{code});
2016 3         25 my $has_sig = !!exists $+{sig};
2017 3 50       18 my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : ();
2018            
2019 3         37 $me->_inject($ref, $pos, $me->_handle_modifier_keyword($kw, $name, $code, $has_sig, $sig, \@attrs));
2020 114 50       2227 } if $want{$kw};
2021             }
2022            
2023             Keyword::Simple::define factory => sub {
2024 3     3   17 my $ref = shift;
2025            
2026 3 100       21 if ( $$ref =~ _fetch_re('MxpFactorySyntax', anchor => 'start') ) {
2027 2         3124 state $re_attr = _fetch_re('MxpAttribute');
2028 2         107 my ($pos, $name, $attributes, $sig, $code) = ($+[0], $+{name}, $+{attributes}, $+{sig}, $+{code});
2029 2         31 my $has_sig = !!exists $+{sig};
2030 2 50       11 my @attrs = $attributes ? grep(defined, ( ($attributes) =~ /($re_attr)/xg )) : ();
2031 2         22 $me->_inject($ref, $pos, $me->_handle_factory_keyword($name, undef, $code, $has_sig, $sig, \@attrs));
2032 2         464 return;
2033             }
2034            
2035 1 50       7 $$ref =~ _fetch_re('MxpFactoryViaSyntax', anchor => 'start') or $me->_syntax_error(
2036             'factory method declaration',
2037             'factory <name> <attributes> (<signature>) { <block> }',
2038             'factory <name> (<signature>) { <block> }',
2039             'factory <name> <attributes> { <block> }',
2040             'factory <name> { <block> }',
2041             'factory <name> via <methodname>',
2042             'factory <name>',
2043             $ref,
2044             );
2045            
2046 1         59 my ($pos, $name, $via) = ($+[0], $+{name}, $+{via});
2047 1   50     6 $via ||= 'new';
2048            
2049 1         11 $me->_inject($ref, $pos, $me->_handle_factory_keyword($name, $via, undef, undef, undef, []));
2050 38 50       1220 } if $want{factory};
2051            
2052             Keyword::Simple::define coerce => sub {
2053 1     1   5 my $ref = shift;
2054            
2055 1 50       13 $$ref =~ _fetch_re('MxpCoerceSyntax', anchor => 'start') or $me->_syntax_error(
2056             'coercion declaration',
2057             'coerce from <type> via <method_name> { <block> }',
2058             'coerce from <type> via <method_name>',
2059             $ref,
2060             );
2061            
2062 1         1136 my ($pos, $from, $via, $code) = ($+[0], $+{from}, $+{via}, $+{code});
2063 1 50       16 if ($from =~ /^\{/) {
    50          
2064 0         0 $from = "scalar(do $from)"
2065             }
2066             elsif ($from !~ /^(q\b)|(qq\b)|"|'/) {
2067 1         6 $from = B::perlstring($from);
2068             }
2069 1 50       11 if ($via =~ /^\{/) {
    50          
2070 0         0 $via = "scalar(do $via)"
2071             }
2072             elsif ($via !~ /^(q\b)|(qq\b)|"|'/) {
2073 1         4 $via = B::perlstring($via);
2074             }
2075            
2076 1 50       19 $me->_inject($ref, $pos, sprintf('q[%s]->_coerce(%s, %s, %s);', $me, $from, $via, $code ? "sub { my \$class; local \$_; (\$class, \$_) = \@_; do $code }" : ''));
2077 38 50       1140 } if $want{coerce};
2078            
2079             # Go!
2080             #
2081             on_scope_end {
2082 31 100   31   228 eval "package $caller; use Zydeco::_Gather -go; 1"
  31     38   180  
  31         150  
  38         3622  
2083             or Carp::croak($@);
2084 38         1158 };
2085            
2086             # Need this to export `authority` and `version`...
2087 38         985 @_ = ($me);
2088 38         262 push @_, grep $want{$_}, @Zydeco::EXPORT;
2089 38         360 goto \&Exporter::Tiny::import;
2090             }
2091              
2092             our $TARGET;
2093             our $EVENT;
2094              
2095             sub _package_callback {
2096 94     94   423653 shift;
2097 94         229 my %args;
2098 94         724 while ( not is_CodeRef $_[0] ) {
2099 79         498 my ( $k, $v ) = splice @_, 0, 2;
2100 79         396 $args{$k} = $v;
2101             }
2102 94         226 my $cb = shift;
2103 94         279 local $TARGET = \%args;
2104 94         424 &$cb;
2105 94         852 return \%args;
2106             }
2107              
2108             sub _define_or_patch (&;$) {
2109 124     124   319 my ($do, $fallback) = @_;
2110            
2111 124         248 my $is_patching = 0;
2112 124 100 66     530 if ( is_HashRef $TARGET ) {
    50          
2113 115         235 $_ = $TARGET;
2114             }
2115             elsif ( is_Str $TARGET or is_Str $fallback ) {
2116 9         31 $_ = {};
2117 9         19 $is_patching = 1;
2118             }
2119             else {
2120 0         0 return;
2121             }
2122            
2123 124         322 $do->();
2124            
2125 124 100       339 if ( $is_patching ) {
2126 9   66     68 my %got = 'MooX::Press'->patch_package( $TARGET||$fallback, %$_ );
2127 9 50       53926 return if keys %got;
2128             }
2129            
2130 124         490 return 1;
2131             }
2132              
2133             sub _define_do_not_patch (&) {
2134 24     24   62 my $do = shift;
2135 24 50       121 if ( is_HashRef $TARGET ) {
2136 24         57 $_ = $TARGET;
2137             }
2138             else {
2139 0         0 return 0;
2140             }
2141 24         75 $do->();
2142 24         102 return 1;
2143             }
2144              
2145             # `version` keyword
2146             #
2147             sub version {
2148 2     2 1 11 my $ver = shift;
2149 2     2   7 _define_or_patch { $_->{version} = $ver } or
2150 2 50       17 __PACKAGE__->_syntax_error('version declaration', 'Not supported outside class or role');
2151             }
2152              
2153             # `authority` keyword
2154             #
2155             sub authority {
2156 0     0 1 0 my $auth = shift;
2157 0     0   0 _define_or_patch { $_->{authority} = $auth } or
2158 0 0       0 __PACKAGE__->_syntax_error('authority declaration', 'Not supported outside class or role');
2159             }
2160              
2161             # `overload` keyword
2162             #
2163             sub overload {
2164 1     1 1 8 my @args = @_;
2165 1 50 33     9 if (@_ == 1 and ref($_[0]) eq 'HASH') {
    50 33        
2166 0         0 @args = %{+shift};
  0         0  
2167             }
2168             elsif (@_ == 1 and ref($_[0]) eq 'ARRAY') {
2169 0         0 @args = @{+shift};
  0         0  
2170             }
2171            
2172 1   50 1   1 _define_or_patch { push @{$_->{overload}||=[]}, @args } or
  1         10  
2173 1 50       4 __PACKAGE__->_syntax_error('overload declaration', 'Not supported outside class');
2174             }
2175              
2176             # `Zydeco::PACKAGE_SPEC` keyword
2177             #
2178             sub PACKAGE_SPEC {
2179 1 50   1 1 18 if (is_HashRef $TARGET) {
2180 1         5 return $TARGET;
2181             }
2182            
2183 0         0 __PACKAGE__->_syntax_error('Zydeco::PACKAGE_SPEC() function', 'Not supported outside class or role');
2184             }
2185              
2186              
2187             #
2188             # CALLBACKS
2189             #
2190              
2191             sub _has {
2192 40     40   3717 my $me = shift;
2193 40         212 my ($attr, %spec) = @_;
2194            
2195 40     40   150 _define_or_patch { $_->{has}{$attr} = \%spec } or
2196 40 50       273 $me->_syntax_error('attribute declaration', 'Not supported outside class or role');
2197             }
2198              
2199             sub _extends {
2200 13     13   121 my $me = shift;
2201 13         79 my @classes = @_;
2202            
2203 13   50 13   30 _define_do_not_patch { @{ $_->{extends}||=[] } = @classes } or
  13         109  
2204 13 50       90 $me->_syntax_error('extends declaration', 'Not supported outside class');
2205             }
2206              
2207             sub _type_name {
2208 1     1   8 my $me = shift;
2209 1         3 my ($name) = @_;
2210            
2211 1     1   3 _define_do_not_patch { $_->{type_name} = $name } or
2212 1 50       7 $me->_syntax_error('extends declaration', 'Not supported outside class or role');
2213             }
2214              
2215             sub _begin {
2216 1     1   12 my $me = shift;
2217 1         3 my ($coderef) = @_;
2218            
2219             _define_do_not_patch {
2220             my $wrapped_coderef = sub {
2221 1         47622 local $TARGET = $_[0];
2222 1         6 local $EVENT = 'begin';
2223 1         3 &$coderef;
2224 1     1   4 };
2225 1   50     3 push @{$_->{begin}||=[]}, $wrapped_coderef;
  1         10  
2226             } or
2227 1 50       8 $me->_syntax_error('begin hook', 'Not supported outside class or role (use import option instead)');
2228             }
2229              
2230             sub _end {
2231 1     1   12 my $me = shift;
2232 1         3 my ($coderef) = @_;
2233            
2234             _define_do_not_patch {
2235             my $wrapped_coderef = sub {
2236 1         54462 local $TARGET = $_[0];
2237 1         4 local $EVENT = 'end';
2238 1         7 &$coderef;
2239 1     1   6 };
2240 1   50     3 push @{$_->{end}||=[]}, $wrapped_coderef;
  1         10  
2241             } or
2242 1 50       7 $me->_syntax_error('end hook', 'Not supported outside class or role (use import option instead)');
2243             }
2244              
2245             sub _before_apply {
2246 2     2   23 my $me = shift;
2247 2         6 my ($coderef) = @_;
2248            
2249             _define_do_not_patch {
2250             my $wrapped_coderef = sub {
2251 3         58391 local $TARGET = $_[1];
2252 3         6 local $EVENT = 'before_apply';
2253 3         11 &$coderef;
2254 2     2   43 };
2255 2   50     7 push @{$_->{before_apply}||=[]}, $wrapped_coderef;
  2         16  
2256 2         6 return;
2257             } or
2258 2 50       17 $me->_syntax_error('before_apply hook', 'Not supported outside role');
2259             }
2260              
2261             sub _after_apply {
2262 2     2   19 my $me = shift;
2263 2         5 my ($coderef) = @_;
2264            
2265             _define_do_not_patch {
2266             my $wrapped_coderef = sub {
2267 3         17905 local $TARGET = $_[1];
2268 3         8 local $EVENT = 'after_apply';
2269 3         11 &$coderef;
2270 2     2   8 };
2271 2   50     5 push @{$_->{after_apply}||=[]}, $wrapped_coderef;
  2         13  
2272 2         5 return;
2273             } or
2274 2 50       11 $me->_syntax_error('after_apply hook', 'Not supported outside role');
2275             }
2276              
2277             sub _interface {
2278 0     0   0 my $me = shift;
2279 0         0 my ($arg) = @_;
2280            
2281 0     0   0 _define_do_not_patch { $_->{interface} = $arg } or
2282 0 0       0 $me->_syntax_error('interface callback', 'Not supported outside role');
2283             }
2284              
2285             sub _abstract {
2286 1     1   8 my $me = shift;
2287 1         4 my ($arg) = @_;
2288            
2289 1     1   4 _define_do_not_patch { $_->{abstract} = $arg } or
2290 1 50       14 $me->_syntax_error('abstract callback', 'Not supported outside class');
2291             }
2292              
2293             sub _with {
2294 17     17   133 my $me = shift;
2295 17         59 my @roles = @_;
2296            
2297 17   50 17   34 _define_or_patch { push @{ $_->{with}||=[] }, @roles } or
  17         143  
2298 17 50       116 $me->_syntax_error('with declaration', 'Not supported outside class or role');
2299             }
2300              
2301             sub _toolkit {
2302 0     0   0 my $me = shift;
2303 0         0 my ($toolkit, @imports) = @_;
2304            
2305             _define_do_not_patch {
2306 0     0   0 $_->{toolkit} = $toolkit;
2307 0 0 0     0 push @{ $_->{import}||=[] }, @imports if @imports;
  0         0  
2308             } or
2309 0 0       0 $me->_syntax_error('toolkit declaration', 'Not supported outside class or role (use import option instead)');
2310             }
2311              
2312             sub _requires {
2313 3     3   23 my $me = shift;
2314 3         13 my @names = @_;
2315            
2316 3   100 3   3 _define_do_not_patch { push @{ $_->{requires}||=[] }, @names } or
  3         22  
2317 3 50       19 $me->_syntax_error('requires declaration', 'Not supported outside role');
2318             }
2319              
2320             sub _coerce {
2321 1     1   11 my $me = shift;
2322 1         4 my @args = @_;
2323            
2324 1   50 1   2 _define_or_patch { push @{$_->{coerce}||=[]}, @args } or
  1         9  
2325 1 50       6 $me->_syntax_error('coercion declaration', 'Not supported outside class');
2326             }
2327              
2328             sub _factory {
2329 3     3   50 my $me = shift;
2330 3         11 my @args = @_;
2331            
2332 3 50 100 3   22 _define_or_patch { push @{$_->{factory}||=[]}, @args } scalar(caller) or
  3         6  
  3         25  
2333             $me->_syntax_error('factory method declaration', 'Not supported outside class');
2334             }
2335              
2336             sub _constant {
2337 12     12   120 my $me = shift;
2338 12         35 my ($name, $value) = @_;
2339            
2340 12 50   12   70 _define_or_patch { $_->{constant}{$name} = $value } scalar(caller) or die;
  12         36  
2341             }
2342              
2343             sub _can {
2344 24     24   14691 my $me = shift;
2345 24         72 my ($name, $code) = @_;
2346            
2347 24 50   24   160 _define_or_patch { $_->{can}{$name} = $code } scalar(caller) or die;
  24         88  
2348             }
2349              
2350             sub _symmethod {
2351 7     7   109 my $me = shift;
2352 7         17 my ($name, $code) = @_;
2353            
2354 7         11 my @new_attr;
2355             my $order;
2356 7         14 for my $attr ( @{ $code->{attributes} } ) {
  7         37  
2357 1 50       12 if ( $attr =~ /^order\((.+)\)$/ ) {
2358 1         6 $order = $1;
2359             }
2360             else {
2361 0         0 push @new_attr, $attr;
2362             }
2363             }
2364            
2365 7 100       22 if ( defined $order ) {
2366 1         3 $code->{attributes} = \@new_attr;
2367 1         3 $code->{order} = $order;
2368             }
2369            
2370 7 50 100 7   43 _define_or_patch { push @{$_->{symmethod}||=[]}, $name, $code } scalar(caller) or die;
  7         10  
  7         42  
2371             }
2372              
2373             sub _multi {
2374 12     12   223 my $me = shift;
2375 12         30 my ($kind, $name, $spec) = @_;
2376            
2377 12 100       38 if ($kind eq 'factory') {
2378 2   100 2   5 _define_or_patch { push @{$_->{multifactory}||=[]}, $name, $spec } or
  2         10  
2379 2 50       10 $me->_syntax_error('multi factory method declaration', 'Not supported outside class');
2380             }
2381             else {
2382 10   100 10   56 _define_or_patch { push @{$_->{multimethod}||=[]}, $name, $spec } scalar(caller);
  10         19  
  10         59  
2383             }
2384             }
2385              
2386             sub _modifier {
2387 5     5   100 my $me = shift;
2388 5         20 my ($kind, @args) = @_;
2389 5   50 5   52 _define_or_patch { push @{$_->{$kind}||=[]}, @args } scalar(caller);
  5         12  
  5         40  
2390             }
2391              
2392             sub _include {
2393 2     2   22 my $me = shift;
2394 2 50       22 is_HashRef($TARGET) and $me->_syntax_error('include directive', 'Not supported inside class or role');
2395            
2396 2         705 require Path::ScanINC;
2397 2         18490 my @chunks = split /::/, $_[0];
2398 2         8 $chunks[-1] .= '.zydeco.pm';
2399 2         22 my $file = Path::ScanINC->new->first_file(@chunks);
2400            
2401 2 50       669 if (!$file) {
2402 0         0 my @fallback = @chunks;
2403 0         0 $fallback[-1] =~ s/\.zydeco\.pm$/.pl/;
2404 0         0 $file = Path::ScanINC->new->first_file(@fallback);
2405 0 0       0 if ($file) {
2406 0         0 require Carp;
2407 0         0 Carp::carp("Include .pl deprecated, use .zydeco.pm instead. Loaded: " . join("/", @fallback));
2408             }
2409             }
2410            
2411 2 50       50 if (!$file) {
2412 0         0 require Carp;
2413 0         0 Carp::croak("No such file: " . join("/", @chunks));
2414             }
2415            
2416 2 50       12 ref $file eq 'ARRAY' and die "not supported yet";
2417 2         12 my $code = $file->slurp_utf8;
2418            
2419 2         1879 sprintf(
2420             "do {\n# line 1 %s\n%s\n};\n1;\n",
2421             B::perlstring($file),
2422             $code,
2423             );
2424             }
2425              
2426             #{
2427             # package Zydeco::Anonymous::Package;
2428             # our $AUTHORITY = 'cpan:TOBYINK';
2429             # our $VERSION = '0.613';
2430             # use overload q[""] => sub { ${$_[0]} }, fallback => 1;
2431             # sub DESTROY {}
2432             # sub AUTOLOAD {
2433             # my $me = shift;
2434             # (my $method = our $AUTOLOAD) =~ s/.*:://;
2435             # $$me->$method(@_);
2436             # }
2437             #
2438             # package Zydeco::Anonymous::Class;
2439             # our $AUTHORITY = 'cpan:TOBYINK';
2440             # our $VERSION = '0.613';
2441             # our @ISA = qw(Zydeco::Anonymous::Package);
2442             # sub new {
2443             # my $me = shift;
2444             # $$me->new(@_);
2445             # }
2446             # use overload q[&{}] => sub {
2447             # my $me = shift;
2448             # sub { $me->new(@_) }
2449             # };
2450             #
2451             # package Zydeco::Anonymous::Role;
2452             # our $AUTHORITY = 'cpan:TOBYINK';
2453             # our $VERSION = '0.613';
2454             # our @ISA = qw(Zydeco::Anonymous::Package);
2455             #
2456             # package Zydeco::Anonymous::ParameterizableClass;
2457             # our $AUTHORITY = 'cpan:TOBYINK';
2458             # our $VERSION = '0.613';
2459             # our @ISA = qw(Zydeco::Anonymous::Package);
2460             # sub generate_package {
2461             # my $me = shift;
2462             # my $gen = $$me->generate_package(@_);
2463             # bless \$gen, 'Zydeco::Anonymous::Class';
2464             # }
2465             # use overload q[&{}] => sub {
2466             # my $me = shift;
2467             # sub { $me->new_class(@_) }
2468             # };
2469             #
2470             # package Zydeco::Anonymous::ParameterizableRole;
2471             # our $AUTHORITY = 'cpan:TOBYINK';
2472             # our $VERSION = '0.613';
2473             # our @ISA = qw(Zydeco::Anonymous::Package);
2474             # sub generate_package {
2475             # my $me = shift;
2476             # my $gen = $$me->generate_package(@_);
2477             # bless \$gen, 'Zydeco::Anonymous::Class';
2478             # }
2479             # use overload q[&{}] => sub {
2480             # my $me = shift;
2481             # sub { $me->new_role(@_) }
2482             # };
2483             #}
2484              
2485             my $i = 0;
2486             sub anonymous_package {
2487 4     4 0 40741 my $me = shift;
2488 4         37 my ($kind, $callback, %opts) = @_;
2489 4         16 my $package_dfn = $me->_package_callback($callback);
2490            
2491 4         12 for my $forbidden (qw/ factory type_name coerce /) {
2492 12 50       31 die if exists $package_dfn->{$forbidden};
2493             }
2494 4         13 $package_dfn->{type_name} = undef;
2495 4         85 $package_dfn->{factory} = undef;
2496            
2497 4         23 my $qname = sprintf('%s::__ANON_%06d__', __PACKAGE__, ++$i);
2498            
2499 4         28 require MooX::Press;
2500 4         12 my $method = "make_$kind";
2501 4         19 MooX::Press->$method(MooX::Press::make_absolute_package_name($qname), %opts, %$package_dfn);
2502            
2503 4         38744 require Module::Runtime;
2504 4         69 $INC{Module::Runtime::module_notional_filename($qname)} = __FILE__;
2505             #return bless(\$qname, "Zydeco::Anonymous::".ucfirst($kind));
2506 4         118 return MooX::Press::make_absolute_package_name($qname);
2507             }
2508              
2509             sub anonymous_generator {
2510 1     1 0 47 my $me = shift;
2511 1         9 my ($kind, $callback, %opts) = @_;
2512 1         6 my $qname = sprintf('%s::__ANON_%06d__', __PACKAGE__, ++$i);
2513            
2514 1         5 require MooX::Press;
2515 1         4 my $method = "make_$kind\_generator";
2516 1         4 MooX::Press->$method(MooX::Press::make_absolute_package_name($qname), %opts, generator => $callback);
2517            
2518 1         795 require Module::Runtime;
2519 1         5 $INC{Module::Runtime::module_notional_filename($qname)} = __FILE__;
2520             #return bless(\$qname, "Zydeco::Anonymous::Parameterizable".ucfirst($kind));
2521 1         29 return MooX::Press::make_absolute_package_name($qname);
2522             }
2523              
2524             1;
2525              
2526             __END__
2527              
2528             =pod
2529              
2530             =encoding utf-8
2531              
2532             =head1 NAME
2533              
2534             Zydeco - Jazz up your Perl
2535              
2536             =head1 SYNOPSIS
2537              
2538             MyApp.pm
2539              
2540             use v5.14;
2541             use strict;
2542             use warnings;
2543            
2544             package MyApp {
2545             use Zydeco;
2546            
2547             class Person {
2548             has name ( type => Str, required => true );
2549             has gender ( type => Str );
2550            
2551             factory new_man (Str $name) {
2552             return $class->new(name => $name, gender => 'male');
2553             }
2554            
2555             factory new_woman (Str $name) {
2556             return $class->new(name => $name, gender => 'female');
2557             }
2558            
2559             method greet (Person *friend, Str *greeting = "Hello") {
2560             printf("%s, %s!\n", $arg->greeting, $arg->friend->name);
2561             }
2562            
2563             coerce from Str via from_string {
2564             return $class->new(name => $_);
2565             }
2566             }
2567             }
2568              
2569             my_script.pl
2570              
2571             use v5.14;
2572             use strict;
2573             use warnings;
2574             use MyApp;
2575             use MyApp::Types qw( is_Person );
2576            
2577             # Create a new MyApp::Person object.
2578             #
2579             my $alice = MyApp->new_woman("Alice");
2580             is_Person($alice) or die;
2581            
2582             # The string "Bob" will be coerced to a MyApp::Person.
2583             #
2584             $alice->greet(friend => "Bob", greeting => 'Hi');
2585              
2586             =head1 DESCRIPTION
2587              
2588             Zydeco is a Perl module to jazz up your object-oriented programming.
2589             It fuses together:
2590              
2591             =over
2592              
2593             =item *
2594              
2595             Classes, roles, and interfaces
2596              
2597             =item *
2598              
2599             Powerful and concise attribute definitions
2600              
2601             =item *
2602              
2603             Methods with signatures, type constraints, and coercion
2604              
2605             =item *
2606              
2607             Factories to help your objects make other objects
2608              
2609             =item *
2610              
2611             Multimethods
2612              
2613             =item *
2614              
2615             Method modifiers to easily wrap or override inherited methods
2616              
2617             =item *
2618              
2619             Powerful delegation features
2620              
2621             =item *
2622              
2623             True private methods and attributes
2624              
2625             =item *
2626              
2627             Parameterizable classes and roles
2628              
2629             =item *
2630              
2631             Syntactic sugar as sweet as pecan pie
2632              
2633             =back
2634              
2635             L<Zydeco::Manual> is probably the best place to start.
2636              
2637             If Zydeco is too slow or has too many dependencies for you, check out
2638             L<Zydeco::Lite>.
2639              
2640             =head1 KEYWORDS
2641              
2642             =head2 C<< class >>
2643              
2644             class MyClass;
2645            
2646             class MyClass { ... }
2647            
2648             class BaseClass {
2649             class SubClass;
2650             }
2651            
2652             class MyGenerator (@args) { ... }
2653             my $class = MyApp->generate_mygenerator(...);
2654            
2655             my $class = do { class; };
2656            
2657             my $class = do { class { ... } };
2658            
2659             my $generator = do { class (@args) { ... } };
2660             my $class = $generator->generate_package(...);
2661              
2662             =head2 C<< abstract class >>
2663              
2664             abstract class MyClass;
2665            
2666             abstract class MyClass { ... }
2667            
2668             abstract class BaseClass {
2669             class SubClass;
2670             }
2671            
2672             my $class = do { abstract class; };
2673            
2674             my $class = do { abstract class { ... } };
2675            
2676             =head2 C<< role >>
2677              
2678             role MyRole;
2679            
2680             role MyRole { ... }
2681            
2682             role MyGenerator (@args) { ... }
2683             my $role = MyApp->generate_mygenerator(...);
2684            
2685             my $role = do { role; };
2686            
2687             my $role = do { role { ... } };
2688            
2689             my $generator = do { role (@args) { ... } };
2690             my $role = $generator->generate_package(...);
2691              
2692             =head2 C<< interface >>
2693              
2694             interface MyIface;
2695            
2696             interface MyIface { ... }
2697            
2698             interface MyGenerator (@args) { ... }
2699             my $interface = MyApp->generate_mygenerator(...);
2700            
2701             my $iface = do { interface; };
2702            
2703             my $iface = do { interface { ... } };
2704            
2705             my $generator = do { interface (@args) { ... } };
2706             my $iface = $generator->generate_package(...);
2707              
2708             =head2 C<< toolkit >>
2709              
2710             class MyClass {
2711             toolkit Moose;
2712             }
2713            
2714             class MyClass {
2715             toolkit Mouse;
2716             }
2717            
2718             class MyClass {
2719             toolkit Moo;
2720             }
2721            
2722             class MyClass {
2723             toolkit Moose (StrictConstructor);
2724             }
2725              
2726             Modules in parentheses are prefixed by C<< "$toolkit\::X" >> unless they start
2727             with "::" and loaded. Not all modules are useful to load this way because they
2728             are loaded too late to have a lexical effect, and because code inside the
2729             class will not be able to see functions exported into the class.
2730              
2731             =head2 C<< extends >>
2732              
2733             class MyClass extends BaseClass;
2734            
2735             class MyClass extends BaseClass, OtherClass;
2736            
2737             class MyClass {
2738             extends BaseClass;
2739             }
2740            
2741             class MyClass {
2742             extends BaseClass, OtherClass;
2743             }
2744              
2745             =head2 C<< with >>
2746              
2747             class MyClass with SomeRole;
2748            
2749             class MyClass with SomeRole, OtherRole;
2750            
2751             class MyClass extends BaseClass with SomeRole, OtherRole;
2752            
2753             class MyClass {
2754             with SomeRole;
2755             }
2756            
2757             class MyClass {
2758             with SomeRole, OtherRole;
2759             }
2760            
2761             class MyClass {
2762             with RoleGenerator(@args), OtherRole;
2763             }
2764            
2765             class MyClass {
2766             with TagRole?, OtherTagRole?;
2767             }
2768            
2769             role MyRole {
2770             with OtherRole;
2771             }
2772            
2773             role MyRole with OtherRole {
2774             ...;
2775             }
2776            
2777             role MyRole with SomeRole, OtherRole;
2778              
2779             =head2 C<< begin >>
2780              
2781             class MyClass {
2782             begin { say "defining $kind $package"; }
2783             }
2784            
2785             role MyRole {
2786             begin { say "defining $kind $package"; }
2787             }
2788              
2789             =head2 C<< end >>
2790              
2791             class MyClass {
2792             end { say "finished defining $kind $package"; }
2793             }
2794            
2795             role MyRole {
2796             end { say "finished defining $kind $package"; }
2797             }
2798              
2799             =head2 C<< before_apply >>
2800              
2801             role MyRole {
2802             before_apply { say "applying $role to $package"; }
2803             }
2804              
2805             =head2 C<< after_apply >>
2806              
2807             role MyRole {
2808             after_apply { say "finished applying $role to $package"; }
2809             }
2810              
2811             =head2 C<< has >>
2812              
2813             class MyClass {
2814             has foo;
2815             }
2816            
2817             class MyClass {
2818             has foo;
2819             class MySubClass {
2820             has +foo;
2821             }
2822             }
2823            
2824             class MyClass {
2825             has foo, bar;
2826             }
2827            
2828             class MyClass {
2829             has foo!, bar;
2830             }
2831            
2832             class MyClass {
2833             has { "fo" . "o" };
2834             }
2835            
2836             class MyClass {
2837             has $foo; # private attribute withg lexical accessor
2838             }
2839            
2840             class MyClass {
2841             has foo ( is => ro, type => Int, default => 1 ) ;
2842             }
2843            
2844             class MyClass {
2845             has name = "Anonymous";
2846             has uc_name = uc($self->name);
2847             }
2848              
2849             =head2 C<< constant >>
2850              
2851             class MyClass {
2852             constant PI = 3.2;
2853             }
2854            
2855             interface Serializable {
2856             requires serialize;
2857             constant PRETTY = 1;
2858             constant UTF8 = 2;
2859             constant CANONICAL = 4;
2860             }
2861              
2862             =head2 C<< method >>
2863              
2864             method myfunc {
2865             ...;
2866             }
2867            
2868             method myfunc ( Int $x, ArrayRef $y ) {
2869             ...;
2870             }
2871            
2872             method myfunc ( HashRef *collection, Int *index ) {
2873             ...;
2874             }
2875            
2876             method myfunc :optimize ( Int $x, ArrayRef $y ) {
2877             ...;
2878             }
2879            
2880             my $myfunc = do { method () {
2881             ...;
2882             }};
2883            
2884             method $myfunc () { # lexical method
2885             ...;
2886             }
2887              
2888             =head2 C<< symmethod >>
2889              
2890             symmethod myfunc {
2891             ...;
2892             }
2893            
2894             symmethod myfunc ( Int $x, ArrayRef $y ) {
2895             ...;
2896             }
2897            
2898             =head2 C<< multi method >>
2899              
2900             multi method myfunc {
2901             ...;
2902             }
2903            
2904             multi method myfunc ( Int $x, ArrayRef $y ) {
2905             ...;
2906             }
2907            
2908             multi method myfunc ( HashRef *collection, Int *index ) {
2909             ...;
2910             }
2911              
2912             =head2 C<< requires >>
2913              
2914             role MyRole {
2915             requires serialize;
2916             requires deserialize (Str $input);
2917             }
2918              
2919             =head2 C<< before >>
2920              
2921             before myfunc {
2922             ...;
2923             }
2924            
2925             before myfunc ( Int $x, ArrayRef $y ) {
2926             ...;
2927             }
2928              
2929             =head2 C<< after >>
2930              
2931             after myfunc {
2932             ...;
2933             }
2934            
2935             after myfunc ( Int $x, ArrayRef $y ) {
2936             ...;
2937             }
2938              
2939             =head2 C<< around >>
2940              
2941             around myfunc {
2942             ...;
2943             my $return = $self->$next( @_[2..$#_] );
2944             ...;
2945             return $return;
2946             }
2947            
2948             around myfunc ( Int $x, ArrayRef $y ) {
2949             ...;
2950             my $return = $self->$next(@_);
2951             ...;
2952             return $return;
2953             }
2954              
2955             =head2 C<< factory >>
2956              
2957             class MyThing {
2958             factory new_thing {
2959             ...;
2960             }
2961             }
2962            
2963             class MyThing {
2964             factory new_thing ( Int $x, ArrayRef $y ) {
2965             ...;
2966             }
2967             }
2968            
2969             class MyThing {
2970             factory new_thing ( HashRef *collection, Int *index ) {
2971             ...;
2972             }
2973             }
2974            
2975             class MyThing {
2976             method _make_thing {
2977             ...;
2978             }
2979             factory new_thing via _make_thing;
2980             }
2981            
2982             class MyThing {
2983             factory new_thing;
2984             }
2985              
2986             =head2 C<< multi factory >>
2987              
2988             class MyThing {
2989             multi factory new_thing ( ArrayRef $x ) {
2990             ...;
2991             }
2992            
2993             multi factory new_thing ( HashRef $x ) {
2994             ...;
2995             }
2996             }
2997              
2998             =head2 C<< type_name >>
2999              
3000             class Person {
3001             type_name Hooman;
3002             }
3003            
3004             role Serializer {
3005             type_name Ser;
3006             }
3007              
3008             =head2 C<< coerce >>
3009              
3010             class Widget {
3011             has id (type => Int);
3012            
3013             coerce from Int via from_id {
3014             $class->new(id => $_);
3015             }
3016             }
3017            
3018             class Widget {
3019             has id (type => Int);
3020            
3021             coerce from Int via from_id;
3022            
3023             method from_id ($id) {
3024             $class->new(id => $id);
3025             }
3026             }
3027              
3028             =head2 C<< overload >>
3029              
3030             class Person {
3031             has name (type => Str);
3032             overload(q[""] => 'name', fallback => true);
3033             }
3034              
3035             =head2 C<< version >>
3036              
3037             class MyClass 1.0;
3038            
3039             class MyClass {
3040             version '1.0';
3041             }
3042              
3043              
3044             =head2 C<< authority >>
3045              
3046             class MyClass {
3047             authority 'cpan:TOBYINK';
3048             }
3049              
3050             =head2 C<< include >>
3051              
3052             package MyApp {
3053             use Zydeco;
3054             include Roles;
3055             include Classes;
3056             }
3057            
3058             # MyApp/Roles.zydeco.pm
3059             role Foo;
3060             role Bar;
3061            
3062             # MyApp/Classes.zydeco.pm
3063             class Foo::Bar with Foo, Bar;
3064              
3065             =head2 C<< Zydeco::PACKAGE_SPEC() >>
3066              
3067             package MyApp {
3068             use Zydeco;
3069            
3070             class MyClass {
3071             has name;
3072             Zydeco::PACKAGE_SPEC()->{has}{name}{required} = true;
3073             }
3074             }
3075              
3076             =head1 IMPORTS
3077              
3078             Booleans:
3079              
3080             =over
3081              
3082             =item C<< true >>
3083              
3084             =item C<< false >>
3085              
3086             =back
3087              
3088             Attribute privacy:
3089              
3090             =over
3091              
3092             =item C<< rw >>
3093              
3094             =item C<< rwp >>
3095              
3096             =item C<< ro >>
3097              
3098             =item C<< lazy >>
3099              
3100             =item C<< bare >>
3101              
3102             =item C<< private >>
3103              
3104             =back
3105              
3106             Utilities:
3107              
3108             =over
3109              
3110             =item C<< blessed($var) >>
3111              
3112             =item C<< confess($format, @args) >>
3113              
3114             =back
3115              
3116             Types:
3117              
3118             use Types::Standard qw( -types -is -assert );
3119             use Types::Common::Numeric qw( -types -is -assert );
3120             use Types::Common::String qw( -types -is -assert );
3121              
3122             Pragmas:
3123              
3124             use strict;
3125             use warnings;
3126            
3127             # Perl 5.14 and Perl 5.16
3128             use feature qw( say state unicode_strings );
3129            
3130             # Perl 5.18 or above
3131             use feature qw( say state unicode_strings
3132             unicode_eval evalbytes current_sub fc );
3133              
3134             Zydeco also imports L<Syntax::Keyword::Try>.
3135              
3136             =head2 Selective Import
3137              
3138             You can choose which parts of Zydeco you import:
3139              
3140             package MyApp {
3141             use Zydeco keywords => [qw/
3142             -booleans
3143             -privacy
3144             -utils
3145             -types
3146             -is
3147             -assert
3148             -features
3149             try
3150             class abstract role interface
3151             begin end before_apply after_apply
3152             include toolkit extends with requires
3153             has constant method multi factory before after around
3154             type_name coerce
3155             version authority overload
3156             /];
3157              
3158             =head2 Unimport
3159              
3160             C<< no Zydeco >> will clear up:
3161              
3162             class abstract role interface
3163             include toolkit begin end extends with requires
3164             has constant method multi factory before after around
3165             type_name coerce
3166             version authority overload
3167              
3168             But won't clear up things Zydeco imported for you from other packages.
3169             Use C<< no MooX::Press::Keywords >>, C<< no Types::Standard >>, etc to
3170             do that, or just use L<namespace::autoclean>.
3171              
3172             =head1 BUGS
3173              
3174             Please report any bugs to
3175             L<http://rt.cpan.org/Dist/Display.html?Queue=Zydeco>.
3176              
3177             =head1 TODO
3178              
3179             =head2 Plugin system
3180              
3181             Zydeco can often load MooX/MouseX/MooseX plugins and work
3182             fine with them, but some things won't work, like plugins that rely on
3183             being able to wrap C<has>. So it would be nice to have a plugin system
3184             that extensions can hook into.
3185              
3186             If you're interested in extending Zydeco, file a bug report about
3187             it and let's have a conversation about the best way for that to happen.
3188             I probably won't start a plugin API until someone actually wants to
3189             write a plugin, because that will give me a better idea about what kind
3190             of API is required.
3191              
3192             =head1 SEE ALSO
3193              
3194             Zydeco manual:
3195             L<Zydeco::Manual>.
3196              
3197             Zydeco website:
3198             L<http://zydeco.toby.ink/>.
3199              
3200             Less magic versions:
3201             L<Zydeco::Lite>,
3202             L<MooX::Press>.
3203             (Zydeco is just a wrapper around MooX::Press, providing a nicer syntax.
3204             Zydeco::Lite is an alternative wrapper, using less magic.)
3205              
3206             Important underlying technologies:
3207             L<Moo>, L<Type::Tiny::Manual>, L<Sub::HandlesVia>, L<Sub::MultiMethod>,
3208             L<Lexical::Accessor>, L<Syntax::Keyword::Try>, L<Role::Hooks>.
3209              
3210             Similar modules:
3211             L<Moops>, L<Kavorka>, L<Dios>, L<MooseX::Declare>.
3212              
3213             =head1 AUTHOR
3214              
3215             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
3216              
3217             =head1 COPYRIGHT AND LICENCE
3218              
3219             This software is copyright (c) 2020 by Toby Inkster.
3220              
3221             This is free software; you can redistribute it and/or modify it under
3222             the