File Coverage

blib/lib/Zydeco.pm
Criterion Covered Total %
statement 784 906 86.5
branch 324 516 62.7
condition 102 175 58.2
subroutine 107 116 92.2
pod 4 6 66.6
total 1321 1719 76.8


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