File Coverage

blib/lib/Zydeco/Lite.pm
Criterion Covered Total %
statement 280 377 74.2
branch 111 208 53.3
condition 57 121 47.1
subroutine 47 64 73.4
pod 0 30 0.0
total 495 800 61.8


line stmt bran cond sub pod time code
1 13     13   1428043 use 5.008008;
  13         140  
2 13     13   52 use strict;
  13         16  
  13         237  
3 13     13   75 use warnings;
  13         16  
  13         663  
4              
5              
6             our $AUTHORITY = 'cpan:TOBYINK';
7             our $VERSION = '0.084';
8              
9             use MooX::Press ();
10 13     13   7162 use Types::Standard qw( -types -is );
  13         231  
  13         381  
11 13     13   72  
  13         20  
  13         153  
12             use Exporter::Shiny our @EXPORT = qw(
13 13         113 app
14             class role abstract_class interface
15             generator
16             method factory constant
17             multi_method multi_factory
18             symmethod
19             before after around
20             extends with has requires
21             confess
22             true false
23             toolkit
24             coerce
25             overload
26             version authority
27             type_name
28             begin end before_apply after_apply
29             );
30 13     13   94507  
  13         4481  
31             use namespace::autoclean;
32 13     13   763  
  13         20  
  13         66  
33             our %THIS;
34              
35             my ( $type, $ref ) = @_;
36             return shift @$ref if @$ref && $type->check( $ref->[0] );
37 238     238   81223 return undef;
38 238 100 100     639 }
39 52         74  
40             my ( $type, $ref ) = @_;
41             return pop @$ref if @$ref && $type->check( $ref->[-1] );
42             return undef;
43 189     189   3748 }
44 189 100 100     617  
45 14         119 {
46             my $app_count = 0;
47             return sprintf( '%s::__ANON__::PKG%07d', __PACKAGE__, ++$app_count );
48             }
49             }
50              
51 11     11   38 my ( $kind, $nameref, $value ) = @_;
52            
53             return $value if is_Undef $nameref;
54            
55             if ( not is_Undef $$nameref ) {
56 11     11   25 confess( '%s name expected to be string or reference to empty scalar variable', $kind );
57             }
58 11 50       58
59             $$nameref = $value;
60 0 0       0 &Internals::SvREADONLY($nameref, 1);
61 0         0 return;
62             }
63              
64 0         0 my ( $level, $coderef ) = @_;
65 0         0
66 0         0 $level = 1 unless defined $level;
67             my ( $pkg, $file, $line ) = caller( $level );
68            
69             if ( defined $coderef ) {
70 133     133   191 require B;
71             my $b = B::svref_2object($coderef);
72 133 50       217 return {
73 133         623 'package' => $pkg,
74             'file' => $b->FILE || $b->START->file || $file,
75 133 100       267 'line' => $b->START->line || $line,
76 112         412 'via' => __PACKAGE__,
77 112         312 };
78             }
79 112   33     1187
      33        
80             return {
81             'package' => $pkg,
82             'file' => $file,
83             'line' => $line,
84             'via' => __PACKAGE__,
85             };
86             }
87 21         87  
88              
89             require Carp;
90             return Carp::confess( @_ > 1 ? sprintf( shift, @_ ) : $_[0] );
91             }
92              
93             my $definition = _pop_type( CodeRef, @_ );
94             my $name = _shift_type( Str|ScalarRef, @_ );
95             my %args = @_;
96            
97             my $package;
98 0     0 0 0 my $is_anon;
99 0 0       0 if ( is_Str $name ) {
100             $package = $name;
101             }
102             else {
103 16     16 0 17024 $is_anon = true;
104 16         441 $package = _anon_package_name();
105 16         167 }
106            
107 16         270 my $caller = caller;
108            
109 16 100       58 local $THIS{APP} = $package;
110 12         22 local $THIS{APP_SPEC} = {
111             caller => $caller,
112             factory_package => $package,
113 4         9 prefix => $package,
114 4         10 toolkit => 'Moo',
115             %args,
116             };
117 16         43 $definition->();
118            
119 16         35 if ( delete $args{debug} ) {
120             require Data::Dumper;
121 16         82 print STDERR Data::Dumper::Dumper( $THIS{APP_SPEC} );
122             }
123            
124             'MooX::Press'->import(
125             %{ $THIS{APP_SPEC} },
126             );
127 16         52
128             if ( $is_anon ) {
129 16 50       81 @_ = ( app => $name, MooX::Press::make_absolute_package_name($package) );
130 0         0 goto \&_return_anon;
131 0         0 }
132             return;
133             }
134              
135 16         27 my $finalize = undef;
  16         173  
136             if ( not $THIS{APP_SPEC} ) {
137             my $caller = caller;
138 16 100       65 $THIS{APP_SPEC} = {
139 4         17 caller => $caller,
140 4         33 toolkit => 'Moo',
141             };
142 12         2455 $finalize = sub {
143             'MooX::Press'->import(
144             %{ $THIS{APP_SPEC} },
145             );
146 84     84 0 390 $THIS{APP_SPEC} = undef;
147 84 100       159 };
148 1         2 }
149            
150 1         4 my $dummy_dfn = false;
151             my $definition = _pop_type( CodeRef, @_ ) || do { $dummy_dfn = true; sub { 1 } };
152             my $name = ( @_ % 2 ) ? _shift_type( Str|ScalarRef, @_ ) : undef;
153             my %args = @_;
154            
155 0     0   0 $args{definition_context} ||= _make_definition_context(1, $dummy_dfn ? () : $definition);
  0         0  
156              
157 0         0 my $kind =
158 1         4 $args{interface} ? 'interface' :
159             $args{abstract} ? 'abstract class' :
160             $args{is_role} ? 'role' :
161 84         102 'class';
162 84   66 5   159
  5         6  
163 84 100       691 if ( delete $args{is_generator} ) {
164 84         574 my $gen = _wrap_generator( @_, $definition );
165            
166 84 100 33     1198 if ( is_Str $name ) {
167             my $key = sprintf(
168             '%s:%s',
169             $args{is_role} ? 'role_generator' : 'class_generator',
170             $name,
171 84 100       248 );
    50          
    50          
172             $THIS{APP_SPEC}{$key} = $gen;
173             $finalize->() if $finalize;
174 84 100       168 return;
175 2         5 }
176             else {
177 2 50       6 my $method = $args{is_role} ? 'make_role_generator' : 'make_class_generator';
178             my $package = _anon_package_name();
179             'MooX::Press'->$method(
180 2 100       7 MooX::Press::make_absolute_package_name($package),
181             %{ $THIS{APP_SPEC} or {} },
182             %args,
183 2         11 generator => $gen,
184 2 50       14 );
185 2         8
186             @_ = ( "$kind generator", $name, MooX::Press::make_absolute_package_name($package) );
187             goto \&_return_anon;
188 0 0       0 }
189 0         0 }
190            
191             my $key = sprintf(
192 0 0       0 '%s:%s',
  0         0  
193             $args{is_role} ? 'role' : 'class',
194             is_Str($name) ? $name : '',
195             );
196            
197 0         0 my $class_spec = do {
198 0         0 local $THIS{CLASS} = is_Str($name) ? $name : undef;
199             local $THIS{CLASS_SPEC} = { %args };
200             $definition->();
201             delete $THIS{CLASS_SPEC}{is_role};
202             $THIS{CLASS_SPEC};
203             };
204 82 100       293
    100          
205             # Anonymous package
206             if ( ! is_Str $name ) {
207             my $method = $args{is_role} ? 'make_role' : 'make_class';
208 82         105 my $package = _anon_package_name();
209 82 100       193 'MooX::Press'->$method(
210 82         229 MooX::Press::make_absolute_package_name($package),
211 82         173 %{ $THIS{APP_SPEC} or {} },
212 82         109 %$class_spec,
213 82         155 );
214             @_ = ( $kind, $name, MooX::Press::make_absolute_package_name($package) );
215             goto \&_return_anon;
216             }
217 82 100       202 # Nested class
    100          
218 7 100       13 elsif ( $THIS{CLASS_SPEC} ) {
219 7         15 defined $THIS{CLASS}
220             or confess('cannot subclass anonymous classes');
221             $THIS{CLASS_SPEC}{is_role}
222 7 50       43 and confess('cannot subclass roles');
  7         50  
223             $THIS{CLASS_SPEC}{is_generator}
224             and confess('cannot subclass class generators');
225 7         20
226 7         45 push @{ $THIS{CLASS_SPEC}{subclass} ||= [] }, $name, $class_spec;
227             }
228             # Otherwise
229             else {
230             $THIS{APP_SPEC}{$key} = $class_spec;
231 29 50       52 }
232            
233 29 50       43 $finalize->() if $finalize;
234             return;
235 29 50       48 }
236              
237 29   100     24 $THIS{APP_SPEC}
  29         893  
238             or confess("`role` used outside an app definition");
239            
240             my $definition = _pop_type( CodeRef, @_ ) || sub { 1 };
241 46         85 push @_, ( is_role => true, $definition );
242             goto \&class;
243             }
244 75 50       129  
245 75         178 $THIS{APP_SPEC}
246             or confess("`abstract_class` used outside an app definition");
247            
248             my $definition = _pop_type( CodeRef, @_ ) || sub { 1 };
249             push @_, ( abstract => true, $definition );
250 31 50   31 0 172 goto \&class;
251             }
252 31   100 6   71  
  6         8  
253 31         203 $THIS{APP_SPEC}
254 31         89 or confess("`interface` used outside an app definition");
255            
256             my $definition = _pop_type( CodeRef, @_ ) || sub { 1 };
257             push @_, ( interface => true, is_role => true, $definition );
258             goto \&class;
259 0 0   0 0 0 }
260              
261 0   0 0   0 my $definition = _pop_type( CodeRef, @_ );
  0         0  
262 0         0 my %args = @_;
263 0         0
264             my $is_role = delete $args{'is_role'};
265             my $app = $THIS{APP_SPEC};
266            
267             my $code = sub {
268 0 0   0 0 0 local $THIS{APP_SPEC} = $app;
269             local $THIS{CLASS_SPEC} = { is_role => $is_role };
270 0   0 0   0 $definition->(@_);
  0         0  
271 0         0 delete $THIS{CLASS_SPEC}{is_role};
272 0         0 return $THIS{CLASS_SPEC};
273             };
274            
275             return { code => $code, %args };
276 2     2   5 }
277 2         14  
278             my $definition = _pop_type( CodeRef, @_ ) || sub { 1 };
279 2         4 my $package = _shift_type( Str|ScalarRef, @_ );
280 2         3 my $sig = _shift_type( Ref, @_ );
281             my %args = @_;
282            
283 3     3   9 return (
284 3         10 $package ? $package : (),
285 3         11 %args,
286 3         6 is_generator => true,
287 3         17 signature => $sig,
288 2         6 $definition,
289             );
290 2         8 }
291              
292             my $next = shift;
293             my $definition = _pop_type( CodeRef, @_ )
294 0   50 0 0 0 or confess('methods must have a body');
  2     2   15  
295 2         28 my $subname = _shift_type( Str|ScalarRef, @_ );
296 2         18 my $sig = _shift_type( Ref, @_ );
297 2         8 my %args = @_;
298            
299             if ( is_ScalarRef $subname or is_Undef $subname ) {
300 2 50       11 my $coderef;
301            
302             if ( $sig or keys %args ) {
303             if ( defined $sig ) {
304             $args{definition_context} = _make_definition_context(1, $definition);
305             $args{caller} = caller;
306             $args{code} = $definition;
307             $args{signature} = $sig;
308             $args{named} = false unless exists $args{named};
309 33     33   48
310 33 50       108 $coderef = 'MooX::Press'->wrap_coderef( \%args );
311             }
312 33         286 }
313 33         258 else {
314 33         83 $coderef = $definition;
315             }
316 33 50 33     156
317 0         0 @_ = ( method => $subname, $coderef );
318             goto &_return_anon;
319 0 0 0     0 }
320 0 0       0
321 0         0 $args{definition_context} = _make_definition_context(1, $definition);
322 0         0 $args{caller} = caller;
323 0         0 $args{code} = $definition;
324 0         0
325 0 0       0 if ( defined $sig ) {
326             $args{signature} = $sig;
327 0         0 $args{named} = false unless exists $args{named};
328             }
329            
330             $next->( $subname, \%args );
331 0         0 return;
332             }
333              
334 0         0 my ( $target, $key ) = $THIS{CLASS_SPEC}
335 0         0 ? ( $THIS{CLASS_SPEC}, 'can' )
336             : ( $THIS{APP_SPEC}, 'factory_package_can' );
337             my $next;
338 33         68
339 33         86 if ( $target ) {
340 33         54 $next = sub {
341             my ( $subname, $args ) = @_;
342 33 100       65 ( $target->{$key} ||= {} )->{$subname} = $args;
343 7         12 };
344 7 100       19 }
345             else {
346             my $caller = caller;
347 33         77 $next = sub {
348 33         119 my ( $subname, $args ) = @_;
349             'MooX::Press'->patch_package( $caller, can => { $subname => $args } );
350             };
351             }
352            
353             unshift @_, $next;
354 21 50   21 0 175 goto \&_method;
355 21         27 }
356              
357 21 50       40 my $next;
358            
359 21     21   39 if ( my $target = $THIS{CLASS_SPEC} || $THIS{APP_SPEC} ) {
360 21   100     102 $next = sub {
361 21         68 my ( $subname, $args ) = @_;
362             push @{ $target->{symmethod} ||= [] }, $subname, $args;
363             };
364 0         0 }
365             else {
366 0     0   0 my $target = $THIS{APP} || caller;
367 0         0 $next = sub {
368 0         0 my ( $subname, $args ) = @_;
369             'MooX::Press'->patch_package( $target, symmethod => { $subname => $args } );
370             };
371 21         55 }
372 21         55
373             unshift @_, $next;
374             goto \&_method;
375             }
376 7     7 0 36  
377             my $subname = is_Str($_[0])
378 7 50 33     15 ? $_[0]
379             : confess('anonymous multi factories not supported');
380 7     7   12 my $target = $THIS{CLASS_SPEC} || $THIS{APP_SPEC};
381 7   100     6 my $next;
  7         22  
382 7         17
383             if ( $target ) {
384             $next = sub {
385 0   0     0 my ( $subname, $args ) = @_;
386             push @{ $target->{multimethod} ||= [] }, $subname, $args;
387 0     0   0 };
388 0         0 }
389 0         0 else {
390             my $caller = shift;
391             $next = sub {
392 7         36 my ( $subname, $args ) = @_;
393 7         15 'MooX::Press'->patch_package( $caller, multimethod => { $subname => $args } );
394             };
395             }
396            
397 3 50   3 0 30 unshift @_, $next;
398             goto \&_method;
399             }
400 3   33     8  
401 3         5 $THIS{CLASS_SPEC}
402             or confess("`factory` used outside a class definition");
403 3 50       6 $THIS{CLASS_SPEC}{is_role}
404             and confess("`factory` used in a role definition");
405 3     3   7
406 3   100     4 if ( @_==0 and not $THIS{CLASS_SPEC}{factory} ) {
  3         15  
407 3         10 $THIS{CLASS_SPEC}{factory} = undef;
408             return;
409             }
410 0         0
411             my $definition = _pop_type( CodeRef|ScalarRef, @_ );
412 0     0   0 my $subnames = _shift_type( Str|ArrayRef, @_ )
413 0         0 or confess("factory cannot be anonymous");
414 0         0 my $sig = _shift_type( Ref, @_ );
415             my %args = @_;
416            
417 3         7 $subnames = [ $subnames ] if is_Str $subnames;
418 3         8 $definition ||= \ "new";
419            
420             if ( ! is_ScalarRef $definition ) {
421             my $code = $definition;
422             $definition = \%args;
423 10 50   10 0 59 $definition->{code} = $code;
424             $definition->{signature} = $sig if $sig;
425 10 50       16 }
426            
427 10 100 66     26 push @{ $THIS{CLASS_SPEC}{factory} ||= [] }, @$subnames, $definition;
428 1         2 }
429 1         1  
430             my $target = $THIS{CLASS_SPEC}
431             or confess("`multi_factory` used outside a class definition");
432 9         17 $target->{is_role}
433 9 50       50 and confess("`multi_factory` used in a role definition");
434            
435 9         80 my $subname = is_Str($_[0])
436 9         14 ? $_[0]
437             : confess('anonymous multi factories not supported');
438 9 100       22
439 9   100     19 unshift @_, sub {
440             my ( $subname, $args ) = @_;
441 9 100       268 push @{ $target->{multifactory} ||= [] }, $subname, $args;
442 3         4 };
443 3         6 goto \&_method;
444 3         6 }
445 3 50       6  
446             my $modifier_type = shift;
447             my $definition = _pop_type( CodeRef, @_ )
448 9   100     10 or confess('methods modifiers must have a body');
  9         45  
449             my $subname = _shift_type( Str|ArrayRef, @_ )
450             or confess("modified methods cannot be anonymous");
451             my $sig = _shift_type( Ref, @_ );
452             my %args = @_;
453 2 50   2 0 4592
454             $args{code} = $definition;
455 2 50       5
456             if ( defined $sig ) {
457 2 50       7 $args{signature} = $sig;
458             $args{named} = false unless exists $args{named};
459             }
460            
461             my @keys = keys %args;
462 2     2   3 if ( @keys > 1 ) {
463 2   50     3 $definition = \%args;
  2         7  
464 2         8 }
465 2         5
466             my $target = $THIS{CLASS_SPEC} || $THIS{APP_SPEC};
467            
468             if ( $target ) {
469 12     12   20 push @{ $target->{$modifier_type} ||= [] }, (
470 12 50       26 ref($subname) ? @$subname : $subname,
471             $definition,
472 12 50       95 );
473             }
474 12         106 else {
475 12         21 my $caller = caller;
476             'MooX::Press'->patch_package( $caller, $modifier_type => { $subname => $definition } );
477 12         21 }
478            
479 12 50       26 return;
480 0         0 }
481 0 0       0  
482             unshift @_, 'before';
483             goto \&_modifier;
484 12         24 }
485 12 50       26  
486 0         0 unshift @_, 'after';
487             goto \&_modifier;
488             }
489 12   66     27  
490             unshift @_, 'around';
491 12 50       26 goto \&_modifier;
492 12 100 50     13 }
  12         81  
493              
494             my $spec = $THIS{CLASS_SPEC} || $THIS{APP_SPEC}
495             or confess("`extends` used outside a class or app definition");
496             $spec->{is_role}
497             and confess("`extends` used in a role definition");
498 0         0
499 0         0 @{ $spec->{extends} ||= [] } = @_;
500            
501             return;
502 12         31 }
503              
504             my $spec = $THIS{CLASS_SPEC} || $THIS{APP_SPEC}
505             or confess("`with` used outside a class, role, or app definition");
506 4     4 0 38
507 4         9 push @{ $spec->{with} ||= [] }, @_;
508            
509             return;
510             }
511 0     0 0 0  
512 0         0 $THIS{CLASS_SPEC}
513             or confess("`has` used outside a class or role definition");
514            
515             my $names = _shift_type( ArrayRef|ScalarRef|Str, @_ )
516 8     8 0 58 or confess("attributes cannot be anonymous");
517 8         24 my $spec = @_ == 1 ? $_[0] : { @_ };
518            
519             if ( is_ArrayRef $spec ) {
520             unshift @$spec, definition_context => _make_definition_context(1);
521             }
522 6 50 33 6 0 75 elsif ( is_HashRef $spec ) {
523             $spec->{definition_context} ||= _make_definition_context(1);
524 6 50       14 }
525            
526 6   50     10 $names = [ $names ] unless is_ArrayRef $names;
  6         26  
527             push @{ $THIS{CLASS_SPEC}{has} ||= [] }, ( $_, $spec ) for @$names;
528 6         42
529             return;
530             }
531              
532             my $names = _shift_type( ArrayRef|Str, @_ )
533 36 50 66 36 0 148 or confess("constants cannot be anonymous");
534             my $value = shift;
535 36   100     51
  36         152  
536             $names = [ $names ] unless is_ArrayRef $names;
537 36         53
538             if ( my $spec = $THIS{CLASS_SPEC} || $THIS{APP_SPEC} ) {
539             ( $spec->{constant} ||= {} )->{$_} = $value for @$names;
540             }
541             else {
542 19 50   19 0 94 my $caller = $THIS{APP} || caller;
543             my %constants;
544 19 50       51 $constants{$_} = $value for @$names;
545             'MooX::Press'->patch_package( $caller, constant => \%constants );
546 19 100       181 }
547            
548 19 50       463 return;
    100          
549 0         0 }
550              
551             $THIS{CLASS_SPEC} && $THIS{CLASS_SPEC}{is_role}
552 16   33     74 or confess("`requires` used outside a role definition");
553            
554             #TODO: handle signatures
555 19 50       69 my ( @subnames ) = @_;
556 19   100     32
  19         82  
557             push @{ $THIS{CLASS_SPEC}{requires} ||= [] }, @subnames;
558 19         39
559             return;
560             }
561              
562 5 50   5 0 24 my $target = $THIS{CLASS_SPEC} || $THIS{APP_SPEC}
563             or confess('`toolkit` used outside app, class, or role definition');
564 5         51
565             my ( $toolkit, @imports ) = @_;
566 5 50       81 confess('no toolkit given') unless $toolkit;
567            
568 5 50 33     17 $target->{toolkit} = $toolkit;
569 5   100     25 push @{ $target->{import} ||= [] }, map {
570             /^::(.+)/ ? $1 : "${toolkit}X::$_";
571             } @imports;
572 0   0     0
573 0         0 return;
574 0         0 }
575 0         0  
576             $THIS{CLASS_SPEC}
577             or confess("`type_name` used outside a class or role definition");
578 5         11
579             @_==1 && ( Str|Undef )->check( $_[0] )
580             or confess("expected type name");
581            
582             $THIS{CLASS_SPEC}{type_name} = shift;
583 0 0 0 0 0 0
584             return;
585             }
586 0         0  
587             my $target = $THIS{CLASS_SPEC} || $THIS{APP_SPEC}
588 0   0     0 or confess("`version` used outside app, class, or role definition");
  0         0  
589             $target->{version} = shift;
590 0         0 return;
591             }
592              
593             my $target = $THIS{CLASS_SPEC} || $THIS{APP_SPEC}
594             or confess("`authority` used outside app, class, or role definition");
595 6 50 33 6 0 44 $target->{authority} = shift;
596             return;
597 6         11 }
598 6 50       11  
599             $THIS{CLASS_SPEC}
600 6         11 or confess("`overload` used outside a class");
601 6   50     32 $THIS{CLASS_SPEC}{is_role}
602 6 0       10 and confess("`overload` used in a role definition");
  0         0  
603            
604             my %overload = @_;
605 6         13
606             $THIS{CLASS_SPEC}{overload} = +{
607             %{ $THIS{CLASS_SPEC}{overload} or {} },
608             %overload,
609             };
610 3 50   3 0 13
611             return;
612 3 50 33     13 }
613              
614             $THIS{CLASS_SPEC}
615 3         2440 or confess("`coerce` used outside a class or role");
616            
617 3         48 my $type = _shift_type( Str|Object, @_ )
618             or confess("expected type to coerce from");
619             my $method = _shift_type( Str, @_ )
620             or confess("expected method name to coerce via");
621             my $code = _shift_type( CodeRef, @_ );
622 3 50 33 3 0 22
623 3         6 push @{ $THIS{CLASS_SPEC}{coerce} ||= [] }, (
624 3         5 $type,
625             $method,
626             $code ? $code : (),
627             );
628            
629 3 50 33 3 0 15 return;
630 3         7 }
631 3         3  
632             my $package = $THIS{CLASS};
633             my %spec = %{ $THIS{CLASS_SPEC} };
634            
635             my %remains = 'MooX::Press'->patch_package(
636 0 0   0 0 0 $package,
637             %spec,
638 0 0       0 );
639             confess( 'bad stuff in %s hook', $THIS{HOOK} )
640 0         0 if keys %remains;
641            
642             return;
643 0 0       0  
  0         0  
644             }
645              
646             $THIS{CLASS_SPEC}
647 0         0 or confess("`begin` used outside a class or role definition");
648            
649             is_CodeRef( my $coderef = shift ) or confess('expected coderef');
650            
651             push @{ $THIS{CLASS_SPEC}{begin} ||= [] }, sub {
652 3 50   3 0 21 local $THIS{CLASS} = $_[0];
653             local $THIS{CLASS_SPEC} = {};
654 3 50       7 local $THIS{HOOK} = 'begin';
655             $coderef->(@_);
656 3 50       27 return _handle_hook(@_);
657             };
658 3         25
659             return;
660 3 50 50     16 }
  3         47  
661              
662             $THIS{CLASS_SPEC}
663             or confess("`end` used outside a class or role definition");
664            
665             is_CodeRef( my $coderef = shift ) or confess('expected coderef');
666 3         10
667             push @{ $THIS{CLASS_SPEC}{end} ||= [] }, sub {
668             local $THIS{CLASS} = $_[0];
669             local $THIS{CLASS_SPEC} = {};
670 6     6   10 local $THIS{HOOK} = 'end';
671 6         9 $coderef->(@_);
  6         20  
672             return _handle_hook(@_);
673 6         29 };
674            
675             return;
676             }
677              
678 6 50       16 $THIS{CLASS_SPEC} && $THIS{CLASS_SPEC}{is_role}
679             or confess("`before_apply` used outside a class or role definition");
680 6         38
681             is_CodeRef( my $coderef = shift ) or confess('expected coderef');
682            
683             require Role::Hooks;
684             push @{ $THIS{CLASS_SPEC}{before_apply} ||= [] }, sub {
685             local $THIS{CLASS} = $_[1];
686 0 0   0 0 0 local $THIS{CLASS_SPEC} = {};
687             local $THIS{HOOK} = 'before_apply';
688 0 0       0 my $kind = 'Role::Hooks'->is_role($_[1]) ? 'role' : 'class';
689             $coderef->(@_, $kind);
690 0   0     0 return _handle_hook(@_);
691 0     0   0 };
692 0         0
693 0         0 return;
694 0         0 }
695 0         0  
696 0         0 $THIS{CLASS_SPEC} && $THIS{CLASS_SPEC}{is_role}
697             or confess("`after_apply` used outside a class or role definition");
698 0         0
699             is_CodeRef( my $coderef = shift ) or confess('expected coderef');
700            
701             require Role::Hooks;
702             push @{ $THIS{CLASS_SPEC}{after_apply} ||= [] }, sub {
703 0 0   0 0 0 local $THIS{CLASS} = $_[1];
704             local $THIS{CLASS_SPEC} = {};
705 0 0       0 local $THIS{HOOK} = 'after_apply';
706             my $kind = 'Role::Hooks'->is_role($_[1]) ? 'role' : 'class';
707 0   0     0 $coderef->(@_, $kind);
708 0     0   0 return _handle_hook(@_);
709 0         0 };
710 0         0
711 0         0 return;
712 0         0 }
713 0         0  
714             true;
715 0         0  
716              
717             =pod
718              
719             =encoding utf-8
720 2 50 33 2 0 20  
721             =head1 NAME
722 2 50       6  
723             Zydeco::Lite - Zydeco without any magic
724 2         333  
725 2   50     16 =head1 SYNOPSIS
726 2     2   992  
727 2         6 use strict;
728 2         3 use warnings;
729 2 50       7 use Zydeco::Lite;
730 2         40
731 2         7 app "Local::MyApp" => sub {
732 2         2242
733             role "Greeting" => sub {
734 2         5
735             method "greeting" => sub {
736             return "Hello";
737             };
738             };
739 3 50 33 3 0 45
740             role generator "Location" => [ "Str" ] => sub {
741 3 50       13 my ( $gen, $arg ) = @_;
742            
743 3         702 method "location" => sub {
744 3   50     21 return $arg;
745 4     4   23734 };
746 4         10 };
747 4         9
748 4 100       9 class "Hello::World" => sub {
749 4         69 with "Greeting";
750 4         13 with "Location" => [ "world" ];
751 3         7244
752             method "do_it" => [] => sub {
753 3         7 my $self = shift;
754             print $self->greeting, " ", $self->location, "\n";
755             };
756             };
757             };
758            
759             my $obj = "Local::MyApp""->new_hello_world;
760             $obj->do_it();
761              
762             =head1 DESCRIPTION
763              
764             L<Zydeco::Lite> is a L<Zydeco>-like module, but without using any parsing
765             tricks. Zydeco requires Perl 5.14 or above, but Zydeco::Lite will run on
766             any version of Perl since 5.8.8.
767              
768             It's intended to be a happy medium between L<Zydeco> and L<MooX::Press>.
769              
770             =head2 Syntax Examples
771              
772             =head3 Apps
773              
774             Apps:
775              
776             app "MyApp" => sub {
777             # definition
778             };
779              
780             Anonymous apps:
781              
782             my $app = app sub {
783             # definition
784             };
785            
786             app \(my $app) => sub {
787             # definition
788             };
789              
790             As of Zydeco::Lite 0.69, classes and roles no longer need to be defined
791             within an C<< app >> block, but bundling them into an app block has the
792             advantage that the app is able to define all its classes and roles
793             together, cross-referencing them, and setting them up in a sensible order.
794             (Which becomes important if you define a role after defining a class that
795             consumes it.)
796              
797             =head3 Classes, Roles, Interfaces, and Abstract Classes
798              
799             Classes:
800              
801             class "MyClass" => sub {
802             # definition
803             };
804              
805             Anonymous classes:
806              
807             my $class = class sub {
808             # definition
809             };
810            
811             my $obj = $class->new();
812              
813             class \(my $class) => sub {
814             # definition
815             };
816            
817             my $obj = $class->new();
818              
819             Class generators:
820              
821             class generator "MyGen" => sub {
822             my ( $gen, @args ) = ( shift, @_ );
823             # definition
824             };
825            
826             my $class = $app->generate_mygen( @args );
827             my $obj = $class->new();
828              
829             class generator "MyGen" => [ @signature ] => sub {
830             my ( $gen, @args ) = ( shift, @_ );
831             # definition
832             };
833              
834             Anonymous class generators:
835              
836             my $gen = class generator sub {
837             my ( $gen, @args ) = ( shift, @_ );
838             # definition
839             };
840            
841             my $class = $gen->generate_package( @args );
842             my $obj = $class->new();
843              
844             class generator \(my $gen) => sub {
845             my ( $gen, @args ) = ( shift, @_ );
846             # definition
847             };
848            
849             my $class = $gen->generate_package( @args );
850             my $obj = $class->new();
851              
852             Roles, interfaces, and abstract classes work the same as classes, but use
853             keywords C<role>, C<interface>, and C<abstract_class>.
854              
855             Inheritance:
856              
857             class "Base" => sub { };
858            
859             class "Derived" => sub {
860             extends "Base";
861             };
862              
863             Inheritance using nested classes:
864              
865             class "Base" => sub {
866             ...;
867            
868             class "Derived" => sub {
869             ...;
870             };
871             };
872              
873             Inheriting from a generated class:
874              
875             class generator "Base" => sub {
876             my ( $gen, @args ) = ( shift, @_ );
877             ...;
878             };
879            
880             class "Derived" => sub {
881             extends "Base" => [ @args ];
882             };
883              
884             Composition:
885              
886             role "Named" => sub {
887             requires "name";
888             };
889            
890             class "Thing" => sub {
891             with "Named";
892             has "name" => ();
893             };
894              
895             Composing an anonymous role:
896              
897             class "Thing" => sub {
898             with role sub {
899             requires "name";
900             };
901            
902             has "name" => ();
903             };
904              
905             Composing a generated role:
906              
907             role generator "Thingy" => sub {
908             my ( $gen, @args ) = ( shift, @_ );
909             ...;
910             };
911            
912             class "Derived" => sub {
913             with "Thingy" => [ @args ];
914             };
915              
916             =head3 Package Settings
917              
918             Class version:
919              
920             class "Foo" => sub {
921             version "1.000";
922             };
923              
924             class "Foo" => ( version => "1.0" )
925             => sub {
926             ...;
927             };
928              
929             Class authority:
930              
931             class "Foo" => sub {
932             authority "cpan:TOBYINK";
933             };
934              
935             class "Foo" => ( version => "1.0", authority => "cpan:TOBYINK" )
936             => sub {
937             ...;
938             };
939              
940             Using non-Moo toolkits:
941              
942             class "Foo" => sub {
943             toolkit "Mouse";
944             };
945              
946             class "Bat" => sub {
947             toolkit "Moose" => ( "StrictConstructor" );
948             };
949              
950             The C<version>, C<authority>, and C<toolkit> keywords can be used within
951             C<app>, C<class>, C<role>, C<interface>, or C<abstract_class> definitions.
952              
953             =head3 Attributes
954              
955             Attributes:
956              
957             has "myattr" => ( ... );
958            
959             has [ "myattr1", "myattr2" ] => ( ... );
960              
961             Private attributes:
962              
963             has "myattr" => ( is => "private", ..., accessor => \(my $accessor) );
964              
965             =head3 Methods
966              
967             Methods:
968              
969             method "mymeth" => sub {
970             my ( $self, @args ) = ( shift, @_ );
971             ...;
972             };
973              
974             Methods with positional signatures:
975              
976             method "mymeth" => [ 'Num', 'Str' ]
977             => sub
978             {
979             my ( $self, $age, $name ) = ( shift, @_ );
980             ...;
981             };
982              
983             Methods with named signatures:
984              
985             method "mymeth" => [ age => 'Num', name => 'Str' ]
986             => ( named => 1 )
987             => sub
988             {
989             my ( $self, $args ) = ( shift, @_ );
990             ...;
991             };
992              
993             Anonymous methods:
994              
995             my $mymeth = method sub {
996             my ( $self, @args ) = ( shift, @_ );
997             ...;
998             }
999              
1000             method \(my $mymeth) => sub {
1001             my ( $self, @args ) = ( shift, @_ );
1002             ...;
1003             }
1004              
1005             Anonymous methods may have signatures.
1006              
1007             Required methods in roles:
1008              
1009             requires "method1", "method2";
1010             requires "method3";
1011              
1012             Method modifiers:
1013              
1014             before "somemethod" => sub {
1015             my ( $self, @args ) = ( shift, @_ );
1016             ...;
1017             };
1018              
1019             after [ "method1", "method2"] => sub {
1020             my ( $self, @args ) = ( shift, @_ );
1021             ...;
1022             };
1023              
1024             around "another" => sub {
1025             my ( $next, $self, @args ) = ( shift, shift, @_ );
1026             ...;
1027             $self->$next( @_ );
1028             ...;
1029             };
1030              
1031             Constants:
1032              
1033             constant "ANSWER_TO_LIFE" => 42;
1034              
1035             Overloading:
1036              
1037             method "to_string" => sub {
1038             my $self = shift;
1039             ...;
1040             };
1041            
1042             overload(
1043             q[""] => "to_string",
1044             fallback => 1,
1045             );
1046              
1047             Factory methods:
1048              
1049             factory "new_foo" => \"new";
1050              
1051             factory "new_foo" => sub {
1052             my ( $factory, $class, @args ) = ( shift, shift, @_ );
1053             return $class->new( @args );
1054             };
1055              
1056             Factory methods may include signatures like methods.
1057              
1058             Indicate you want a class to have no factories:
1059              
1060             factory();
1061              
1062             The keywords C<multi_method> and C<multi_factory> exist for multimethods.
1063              
1064             The keyword C<symmethod> exists for symmethods.
1065              
1066             =head3 Types
1067              
1068             Setting the type name for a class or role:
1069              
1070             class "Foo::Bar" => sub {
1071             type_name "Foobar";
1072             ...;
1073             };
1074              
1075             Coercion:
1076              
1077             class "Foo::Bar" => sub {
1078             method "from_arrayref" => sub {
1079             my ( $class, $aref ) = ( shift, @_ );
1080             ...;
1081             };
1082             coerce "ArrayRef" => "from_arrayref";
1083             };
1084              
1085             class "Foo::Bar" => sub {
1086             coerce "ArrayRef" => "from_arrayref" => sub {
1087             my ( $class, $aref ) = @_;
1088             ...;
1089             };
1090             };
1091              
1092             =head3 Hooks
1093              
1094             Hooks for classes:
1095              
1096             begin {
1097             my ( $class ) = ( shift );
1098             # Code that runs early during class definition
1099             };
1100              
1101             end {
1102             my ( $class ) = ( shift );
1103             # Code that runs late during class definition
1104             };
1105              
1106             Hooks for roles:
1107              
1108             begin {
1109             my ( $role ) = ( shift );
1110             # Code that runs early during role definition
1111             };
1112              
1113             end {
1114             my ( $role ) = ( shift );
1115             # Code that runs late during role definition
1116             };
1117              
1118             before_apply {
1119             my ( $role, $target, $targetkind ) = ( shift, @_ );
1120             # Code that runs before a role is applied to a package
1121             };
1122              
1123             after_apply {
1124             my ( $role, $target, $targetkind ) = ( shift, @_ );
1125             # Code that runs after a role is applied to a package
1126             };
1127              
1128             =head3 Utilities
1129              
1130             Booleans:
1131              
1132             my $truth = true;
1133             my $truth = false;
1134              
1135             Exceptions:
1136              
1137             confess( 'Something bad happened' );
1138             confess( 'Exceeded maximum (%d)', $max );
1139              
1140             =head2 Formal Syntax
1141              
1142             Scope B<ANY> means the keyword can appear anywhere where Zydeco::Lite
1143             is in scope. Scope B<CLASS> means that the keyword may appear only within
1144             class or abstract class definition blocks. Scope B<ROLE> means that the
1145             keyword may appear only in role/interface definition blocks. Scope B<APP>
1146             means that the keyword may appear only within an app definition block.
1147              
1148             # Scope: ANY
1149             app(
1150             Optional[Str|ScalarRef] $name,
1151             Hash %args,
1152             Optional[CodeRef] $definition,
1153             );
1154            
1155             # Scope: ANY
1156             class(
1157             Optional[Str|ScalarRef] $name,
1158             Hash %args,
1159             Optional[CodeRef] $definition,
1160             );
1161            
1162             # Scope: ANY
1163             class generator(
1164             Optional[Str|ScalarRef] $name,
1165             Optional[ArrayRef] $signature,
1166             Hash %args,
1167             Optional[CodeRef] $definition,
1168             );
1169            
1170             # Scope: ANY
1171             role(
1172             Optional[Str|ScalarRef] $name,
1173             Hash %args,
1174             Optional[CodeRef] $definition,
1175             );
1176            
1177             # Scope: ANY
1178             role generator(
1179             Optional[Str|ScalarRef] $name,
1180             Optional[ArrayRef] $signature,
1181             Hash %args,
1182             Optional[CodeRef] $definition,
1183             );
1184            
1185             # Scope: ANY
1186             interface(
1187             Optional[Str|ScalarRef] $name,
1188             Hash %args,
1189             Optional[CodeRef] $definition,
1190             );
1191            
1192             # Scope: ANY
1193             interface generator(
1194             Optional[Str|ScalarRef] $name,
1195             Optional[ArrayRef] $signature,
1196             Hash %args,
1197             Optional[CodeRef] $definition,
1198             );
1199            
1200             # Scope: ANY
1201             abstract_class(
1202             Optional[Str|ScalarRef] $name,
1203             Hash %args,
1204             Optional[CodeRef] $definition,
1205             );
1206            
1207             # Scope: ANY
1208             abstract_class generator(
1209             Optional[Str|ScalarRef] $name,
1210             Optional[ArrayRef] $signature,
1211             Hash %args,
1212             Optional[CodeRef] $definition,
1213             );
1214            
1215             # Scope: CLASS or APP
1216             extends(
1217             List[Str|ArrayRef] @parents,
1218             );
1219            
1220             # Scope: ANY
1221             with(
1222             List[Str|ArrayRef] @parents,
1223             );
1224            
1225             # Scope: ANY
1226             method(
1227             Optional[Str|ScalarRef] $name,
1228             Optional[ArrayRef] $signature,
1229             Hash %args,
1230             CodeRef $body,
1231             );
1232            
1233             # Scope: CLASS
1234             factory(
1235             Str|ArrayRef $names,
1236             Optional[ArrayRef] $signature,
1237             Hash %args,
1238             CodeRef|ScalarRef $body_or_via,
1239             );
1240            
1241             # Scope: ANY
1242             constant(
1243             Str|ArrayRef $names,
1244             Any $value,
1245             );
1246            
1247             # Scope: ANY
1248             multi_method(
1249             Str $name,
1250             ArrayRef $signature,
1251             Hash %args,
1252             CodeRef $body,
1253             );
1254            
1255             # Scope: CLASS
1256             multi_factory(
1257             Str $name,
1258             ArrayRef $signature,
1259             Hash %args,
1260             CodeRef $body,
1261             );
1262            
1263             # Scope: ANY
1264             symmethod(
1265             Str $name,
1266             ArrayRef $signature,
1267             Hash %args,
1268             CodeRef $body,
1269             );
1270            
1271             # Scope: ANY
1272             before(
1273             Str|ArrayRef $names,
1274             Optional[ArrayRef] $signature,
1275             Hash %args,
1276             CodeRef $body,
1277             );
1278            
1279             # Scope: ANY
1280             after(
1281             Str|ArrayRef $names,
1282             Optional[ArrayRef] $signature,
1283             Hash %args,
1284             CodeRef $body,
1285             );
1286            
1287             # Scope: ANY
1288             around(
1289             Str|ArrayRef $names,
1290             Optional[ArrayRef] $signature,
1291             Hash %args,
1292             CodeRef $body,
1293             );
1294            
1295             # Scope: CLASS or ROLE
1296             has(
1297             Str|ArrayRef $names,
1298             Hash|HashRef|ArrayRef %spec,
1299             );
1300            
1301             # Scope: ROLE
1302             requires(
1303             List[Str] @names,
1304             );
1305            
1306             # Scope: ANY
1307             confess(
1308             Str $template,
1309             List @args,
1310             );
1311            
1312             # Scope: APP or CLASS or ROLE
1313             toolkit(
1314             Str $toolkit,
1315             Optional[List] @imports,
1316             );
1317            
1318             # Scope: CLASS or ROLE
1319             coerce(
1320             Object|Str $type,
1321             Str $via,
1322             Optional[CodeRef] $definition,
1323             );
1324            
1325             # Scope: CLASS
1326             overload(
1327             Hash %args,
1328             );
1329            
1330             # Scope: APP or CLASS or ROLE
1331             version(
1332             Str $version,
1333             );
1334            
1335             # Scope: APP or CLASS or ROLE
1336             authority(
1337             Str $authority,
1338             );
1339            
1340             # Scope: CLASS or ROLE
1341             type_name(
1342             Str $name,
1343             );
1344            
1345             # Scope: CLASS or ROLE
1346             begin {
1347             my ( $package ) = @_;
1348             ...;
1349             };
1350            
1351             # Scope: CLASS or ROLE
1352             end {
1353             my ( $package ) = @_;
1354             ...;
1355             };
1356            
1357             # Scope: ROLE
1358             before_apply {
1359             my ( $role, $target, $targetkind ) = @_;
1360             ...;
1361             };
1362            
1363             # Scope: ROLE
1364             after_apply {
1365             my ( $role, $target, $targetkind ) = @_;
1366             ...;
1367             };
1368              
1369             Scopes are dynamic rather than lexical. So although C<extends> can only appear
1370             in a B<CLASS>, this will work:
1371              
1372             use Zydeco::Lite;
1373            
1374             class "Base";
1375            
1376             sub foo { extends "Base" }
1377            
1378             class "Derived" => sub { foo() };
1379              
1380             Keywords used within a C<before_apply> or C<after_apply> block execute in the
1381             scope of the package they're being applied to. They run too late for
1382             C<type_name> to work, but most other keywords will work okay. In the following
1383             example, Derived will be a child class of Base.
1384              
1385             use Zydeco::Lite;
1386            
1387             class "Base";
1388            
1389             role "ChildOfBase" => sub {
1390             after_apply {
1391             my ( $role, $target, $kind ) = @_;
1392             extends "Base" if $kind eq "class";
1393             };
1394             };
1395            
1396             class "Derived" => sub {
1397             with "ChildOfBase";
1398             };
1399              
1400             =head2 Import
1401              
1402             Zydeco::Lite uses L<Exporter::Tiny>, so you can choose which keywords
1403             to import, rename them, etc.
1404              
1405             use Zydeco::Lite { -prefix => 'zy_' };
1406            
1407             my $app = zy_app {
1408             zy_class 'Foo' => sub {};
1409             };
1410            
1411             my $obj = $app->new_foo();
1412              
1413             =head1 EXAMPLE
1414              
1415             package Zoo;
1416             use strict;
1417             use warnings;
1418             use Zydeco::Lite;
1419            
1420             my $app = __PACKAGE__;
1421            
1422             app $app => sub {
1423            
1424             class 'Park' => sub {
1425            
1426             has 'name' => (
1427             type => 'Str',
1428             );
1429            
1430             has 'animals' => (
1431             type => 'ArrayRef',
1432             default => sub { [] },
1433             handles_via => 'Array',
1434             handles => [
1435             'add_animal' => 'push',
1436             'list_animals' => 'all',
1437             ],
1438             );
1439            
1440             method 'print_animals' => [] => sub {
1441             my ( $self ) = ( shift );
1442             for my $animal ( $self->list_animals ) {
1443             $animal->print_animal;
1444             }
1445             };
1446             };
1447            
1448             role generator 'Animal' => [ 'Str' ] => sub {
1449             my ( $gen, $species ) = ( shift, @_ );
1450            
1451             has 'name' => ( type => 'Str', required => true );
1452            
1453             method 'print_animal' => [] => sub {
1454             my ( $self ) = ( shift );
1455             printf( "%s (%s)\n", $self->name, $species );
1456             };
1457             };
1458            
1459             class 'Lion' => sub {
1460             with 'Animal' => [ 'Panthera leo' ];
1461             };
1462            
1463             class 'Tiger' => sub {
1464             with 'Animal' => [ 'Panthera tigris' ];
1465             };
1466            
1467             class 'Bear' => sub {
1468             with 'Animal' => [ 'Ursus arctos' ];
1469             };
1470             };
1471            
1472             my $zoo = $app->new_park( name => "Oz Zoo" );
1473             $zoo->add_animal( $app->new_lion( name => "Simba" ) );
1474             $zoo->add_animal( $app->new_lion( name => "Aslan" ) );
1475             $zoo->add_animal( $app->new_tiger( name => "Tigger" ) );
1476             $zoo->add_animal( $app->new_tiger( name => "Shere Khan" ) );
1477             $zoo->add_animal( $app->new_bear( name => "Paddington" ) );
1478             $zoo->add_animal( $app->new_bear( name => "Yogi" ) );
1479             $zoo->print_animals; # oh my!
1480              
1481             =head1 BUGS
1482              
1483             Please report any bugs to
1484             L<http://rt.cpan.org/Dist/Display.html?Queue=MooX-Press>.
1485              
1486             =head1 SEE ALSO
1487              
1488             L<Zydeco>, L<MooX::Press>.
1489              
1490             =head1 AUTHOR
1491              
1492             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
1493              
1494             =head1 COPYRIGHT AND LICENCE
1495              
1496             This software is copyright (c) 2020 by Toby Inkster.
1497              
1498             This is free software; you can redistribute it and/or modify it under
1499             the same terms as the Perl 5 programming language system itself.
1500              
1501             =head1 DISCLAIMER OF WARRANTIES
1502              
1503             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
1504             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
1505             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
1506