File Coverage

blib/lib/Hades/Realm/Exporter.pm
Criterion Covered Total %
statement 276 286 96.5
branch 178 240 74.1
condition 91 115 79.1
subroutine 24 26 92.3
pod 21 21 100.0
total 590 688 85.7


line stmt bran cond sub pod time code
1             package Hades::Realm::Exporter;
2 6     6   1762766 use strict;
  6         63  
  6         173  
3 6     6   32 use warnings;
  6         15  
  6         180  
4 6     6   31 use base qw/Hades/;
  6         14  
  6         20762  
5             our $VERSION = 0.03;
6              
7             sub new {
8 31 100   31 1 53461 my ( $cls, %args ) = ( shift(), scalar @_ == 1 ? %{ $_[0] } : @_ );
  29         106  
9 31         135 my $self = $cls->SUPER::new(%args);
10 31         369 my %accessors = ( export => { default => {}, }, );
11 31         85 for my $accessor ( keys %accessors ) {
12             my $value
13             = $self->$accessor(
14             defined $args{$accessor}
15             ? $args{$accessor}
16 31 100       132 : $accessors{$accessor}->{default} );
17 29 50 33     120 unless ( !$accessors{$accessor}->{required} || defined $value ) {
18 0         0 die "$accessor accessor is required";
19             }
20             }
21 29         204 return $self;
22             }
23              
24             sub export {
25 48     48 1 1082 my ( $self, $value ) = @_;
26 48 100       127 if ( defined $value ) {
27 34 100 100     119 if ( ( ref($value) || "" ) ne "HASH" ) {
28 4         33 die qq{HashRef: invalid value $value for accessor export};
29             }
30 30         85 $self->{export} = $value;
31             }
32 44         107 return $self->{export};
33             }
34              
35             sub build_self {
36 12     12 1 591 my ( $self, $name ) = @_;
37 12 50       33 if ( defined $name ) {
38 12 100       33 if ( ref $name ) {
39 2         16 die
40             qq{Optional[Str]: invalid value $name for variable \$name in method build_self};
41             }
42             }
43              
44 10         45 return qq|$name|;
45              
46             }
47              
48             sub default_export_hash {
49 11     11 1 2462 my ( $self, $mg, $class, $export ) = @_;
50 11 100 100     80 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
51 2 50       6 $mg = defined $mg ? $mg : 'undef';
52 2         17 die
53             qq{Object: invalid value $mg for variable \$mg in method default_export_hash};
54             }
55 9 100 100     53 if ( ( ref($class) || "" ) ne "HASH" ) {
56 2 50       5 $class = defined $class ? $class : 'undef';
57 2         14 die
58             qq{HashRef: invalid value $class for variable \$class in method default_export_hash};
59             }
60 7 100       23 $export = defined $export ? $export : {};
61 7 100 100     29 if ( ( ref($export) || "" ) ne "HASH" ) {
62 2 50       5 $export = defined $export ? $export : 'undef';
63 2         14 die
64             qq{HashRef: invalid value $export for variable \$export in method default_export_hash};
65             }
66              
67 5 100 66     34 if ( $class->{CURRENT}->{BASE} || $class->{CURRENT}->{PARENT} ) {
68 1         2 for my $cls (
69 1 50       6 @{ $class->{CURRENT}->{BASE} || [] },
70 1 50       6 @{ $class->{CURRENT}->{PARENT} || [] }
71             )
72             {
73 1 50       4 if ( $self->export->{$cls} ) {
74 1         2 my %unique;
75 1         2 for ( keys %{ $self->export->{$cls} } ) {
  1         2  
76 5         11 push @{ $export->{$_} },
77 39         55 map { $unique{$_}++; $_; }
  39         65  
78 5         7 @{ $self->export->{$cls}->{$_} };
  5         9  
79             }
80 1         6 for ( keys %unique ) {
81 13         39 $self->build_sub_no_arguments( $mg,
82             [ $_, "return ${cls}::$_(\@_)" ], {} );
83             }
84             }
85             else { }
86             }
87             }
88 5         13 return $export;
89              
90             }
91              
92             sub build_new {
93 9     9 1 1680 my ( $self, $mg, $meta, $our ) = @_;
94 9 100 100     70 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
95 2 50       6 $mg = defined $mg ? $mg : 'undef';
96 2         17 die
97             qq{Object: invalid value $mg for variable \$mg in method build_new};
98             }
99 7 100 100     33 if ( ( ref($meta) || "" ) ne "HASH" ) {
100 2 50       7 $meta = defined $meta ? $meta : 'undef';
101 2         16 die
102             qq{HashRef: invalid value $meta for variable \$meta in method build_new};
103             }
104 5 50       18 $our = defined $our ? $our : q|@EXPORT, @EXPORT_OK, %EXPORT_TAGS|;
105              
106 5         22 my %class = %Module::Generate::CLASS;
107 5         14 my $begin = '';
108 5         20 my $export = $self->default_export_hash( $mg, \%class );
109 5         13 for ( keys %{$meta} ) {
  5         18  
110 30 50       123 if ( $meta->{$_}->{meta} =~ m/^(ACCESSOR|METHOD)$/ ) {
111 30 100       77 if ( $1 eq 'ACCESSOR' ) {
112             $begin .= $_ . q| => | . $meta->{$_}->{default} . q|, |
113 24 100       68 if $meta->{$_}->{default};
114             }
115 30         52 my $import = $meta->{$_}->{import};
116 30         40 my $now = shift @{$import};
  30         47  
117 30         110 $self->build_export_tags( $_, "${1}S", $export, $now, $import );
118             $self->build_export_tags( "has_$_", 'PREDICATES', $export, $now,
119             [] )
120 30 100       83 if $meta->{$_}->{predicate};
121             $self->build_export_tags( "clear_$_", 'CLEARERS', $export, $now,
122             [] )
123 30 100       86 if $meta->{$_}->{clearer};
124             }
125             }
126 5         10 $self->export->{ $class{CURRENT}{NAME} } = { %{$export} };
  5         44  
127 5         38 $mg->our( '(' . $our . ', %ACCESSORS)' );
128 5         80 $begin = $self->build_exporter( '%ACCESSORS = (' . $begin . ')',
129             $mg, $export, $meta );
130 5 50       28 if ( $class{CURRENT}{BEGIN} ) {
131 0         0 ( my $code = $class{CURRENT}{BEGIN} ) =~ s/\s*\}\s*$//;
132 0         0 $begin = $code . $begin . "\}";
133             }
134 5         41 else { $begin = qq|{ $begin }|; }
135 5         23 $class{CURRENT}{BEGIN} = $begin;
136 5         98 delete $class{CURRENT}{SUBS}{new};
137              
138             }
139              
140             sub build_exporter {
141 13     13 1 3524 my ( $self, $begin, $mg, $export, $meta ) = @_;
142 13 100 66     92 if ( !defined($begin) || ref $begin ) {
143 2 50       6 $begin = defined $begin ? $begin : 'undef';
144 2         16 die
145             qq{Str: invalid value $begin for variable \$begin in method build_exporter};
146             }
147 11 100 100     71 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
148 2 50       5 $mg = defined $mg ? $mg : 'undef';
149 2         15 die
150             qq{Object: invalid value $mg for variable \$mg in method build_exporter};
151             }
152 9 100 100     45 if ( ( ref($export) || "" ) ne "HASH" ) {
153 2 50       6 $export = defined $export ? $export : 'undef';
154 2         14 die
155             qq{HashRef: invalid value $export for variable \$export in method build_exporter};
156             }
157 7 100 100     31 if ( ( ref($meta) || "" ) ne "HASH" ) {
158 2 50       6 $meta = defined $meta ? $meta : 'undef';
159 2         14 die
160             qq{HashRef: invalid value $meta for variable \$meta in method build_exporter};
161             }
162              
163 5         29 my $ex = delete $export->{EXPORT};
164 5         11 my $ex_ok = delete $export->{EXPORT_OK};
165 5         22 my $ex_tags = Module::Generate::_stringify_struct( 'undefined', $export );
166 5         6066 $ex_tags =~ s/^{/(/;
167 5         22 $ex_tags =~ s/}$/);/;
168             $begin
169             = '@EXPORT = ('
170 33         72 . join( ', ', map {qq|'$_'|} @{$ex} ) . ');'
  5         22  
171             . '@EXPORT_OK = ('
172 5         11 . join( ', ', map {qq|'$_'|} @{$ex_ok} ) . ');'
  56         137  
  5         13  
173             . '%EXPORT_TAGS = '
174             . $ex_tags
175             . $begin;
176 5         27 return $begin;
177              
178             }
179              
180             sub build_export_tags {
181 53     53 1 5496 my ( $self, $name, $type, $export, $now, $import ) = @_;
182 53 100 66     192 if ( !defined($name) || ref $name ) {
183 2 50       5 $name = defined $name ? $name : 'undef';
184 2         16 die
185             qq{Str: invalid value $name for variable \$name in method build_export_tags};
186             }
187 51 100 66     150 if ( !defined($type) || ref $type ) {
188 2 50       16 $type = defined $type ? $type : 'undef';
189 2         18 die
190             qq{Str: invalid value $type for variable \$type in method build_export_tags};
191             }
192 49 100 100     120 if ( ( ref($export) || "" ) ne "HASH" ) {
193 2 50       4 $export = defined $export ? $export : 'undef';
194 2         27 die
195             qq{HashRef: invalid value $export for variable \$export in method build_export_tags};
196             }
197 47 100       95 if ( defined $now ) {
198 32 100 100     142 if ( ref $now || $now !~ m/^[-+\d]\d*$/ ) {
199 2         16 die
200             qq{Optional[Int]: invalid value $now for variable \$now in method build_export_tags};
201             }
202             }
203 45 100 100     180 if ( !defined($import) || ( ref($import) || "" ) ne "ARRAY" ) {
      66        
204 2 50       7 $import = defined $import ? $import : 'undef';
205 2         16 die
206             qq{ArrayRef: invalid value $import for variable \$import in method build_export_tags};
207             }
208              
209 43         61 push @{ $export->{$type} }, $name;
  43         96  
210 43         65 push @{ $export->{EXPORT_OK} }, $name;
  43         76  
211 43 100       79 push @{ $export->{EXPORT} }, $name if $now;
  20         39  
212 43         54 for my $i ( @{$import} ) {
  43         75  
213 2         7 $i =~ s/^\s*|\s*$//;
214 2         28 push @{ $export->{$i} }, $name;
  2         7  
215             }
216 43         102 return $export;
217              
218             }
219              
220             sub after_class {
221 7     7 1 679 my ( $self, $mg ) = @_;
222 7 100 100     54 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
223 2 50       6 $mg = defined $mg ? $mg : 'undef';
224 2         17 die
225             qq{Object: invalid value $mg for variable \$mg in method after_class};
226             }
227              
228 5         25 $mg->use(q|Exporter qw/import/|);
229              
230             }
231              
232             sub build_sub_or_accessor_attributes {
233 30     30 1 35205 my ( $orig, $self, @params )
234             = ( 'SUPER::build_sub_or_accessor_attributes', @_ );
235              
236 30         175 my @res = $self->$orig(@params);
237             unshift @res, (
238             qr/^(\:import|\:i$)/ => sub {
239 6     6   2587 $params[-1]->{ $params[-3] }->{import} = [0];
240             },
241             qr/^(\:import|\:i)\(/ => sub {
242 14     14   3199 my $value = shift;
243 14         99 $value =~ s/(\:import|\:i)\((.*)\)$/$2/sg;
244 14         99 $params[-1]->{ $params[-3] }->{import} = [ split /,/, $value ];
245             }
246 30         1134 );
247              
248 30 50       187 return wantarray ? @res : $res[0];
249             }
250              
251             sub build_accessor_no_arguments {
252 0     0 1 0 my ( $self, $mg, $token, $meta ) = @_;
253              
254 0         0 $meta->{ $token->[0] }->{meta} = 'ACCESSOR';
255             $mg->accessor( $token->[0] )
256             ->code( $self->build_accessor_code( $token->[0], '', '', '' ) )
257             ->clear_tests->test(
258             $self->build_tests(
259 0         0 $token->[0], $meta->{ $token->[0] },
260             '', {%Module::Generate::CLASS}
261             )
262             )->pod(qq|call $token->[0] accessor function.|)
263             ->example(qq|$token->[0](\$value)|);
264 0         0 return $meta;
265              
266             }
267              
268             sub build_accessor_code {
269 32     32 1 4824 my ( $self, $name, $private, $type, $trigger ) = @_;
270 32 100 66     117 if ( !defined($name) || ref $name ) {
271 2 50       5 $name = defined $name ? $name : 'undef';
272 2         18 die
273             qq{Str: invalid value $name for variable \$name in method build_accessor_code};
274             }
275 30 100 66     103 if ( !defined($private) || ref $private ) {
276 2 50       16 $private = defined $private ? $private : 'undef';
277 2         17 die
278             qq{Str: invalid value $private for variable \$private in method build_accessor_code};
279             }
280 28 100 66     113 if ( !defined($type) || ref $type ) {
281 2 50       5 $type = defined $type ? $type : 'undef';
282 2         17 die
283             qq{Str: invalid value $type for variable \$type in method build_accessor_code};
284             }
285 26 100 66     105 if ( !defined($trigger) || ref $trigger ) {
286 2 50       5 $trigger = defined $trigger ? $trigger : 'undef';
287 2         17 die
288             qq{Str: invalid value $trigger for variable \$trigger in method build_accessor_code};
289             }
290              
291 24         158 return qq|{
292             my ( \$value ) = \@_; $private
293             if ( defined \$value ) { $type
294             \$ACCESSORS{$name} = \$value; $trigger
295             }
296             return \$ACCESSORS{$name};
297             }|;
298              
299             }
300              
301             sub build_accessor {
302 24     24 1 4158 my ( $orig, $self, @params ) = ( 'SUPER::build_accessor', @_ );
303              
304 24         86 my @res = $self->$orig(@params);
305             $params[0]->clear_tests->test(
306             $self->build_tests(
307 24         67 $params[1], $params[2]->{ $params[1] },
308             '', {%Module::Generate::CLASS}
309             )
310             );
311             $params[0]->pod(
312             sprintf
313             q|call %s accessor function. Expects a single param to be of type %s.|,
314             $params[1],
315             $params[2]->{ $params[1] }->{type}->[0] || 'Any'
316 24 50 100     441 ) unless $params[2]->{ $params[1] }->{pod};
317             $params[0]->example(qq|$params[1]()|)
318 24 50       239 unless $params[2]->{ $params[1] }->{example};
319              
320 24 50       183 return wantarray ? @res : $res[0];
321             }
322              
323             sub build_modify {
324 0     0 1 0 my ($self) = @_;
325              
326             }
327              
328             sub build_sub_no_arguments {
329 13     13 1 23 my ( $self, $mg, $token, $meta ) = @_;
330              
331 13         18 my $name = shift @{$token};
  13         20  
332             $name =~ m/^(begin|unitcheck|check|init|end|new)$/
333 0         0 ? $mg->$name( join ' ', @{$token} )
334             : $mg->sub($name)
335 13 50       48 ->code( $self->build_sub_code( '', '', '', join( ' ', @{$token} ) ) )
  13         131  
336             ->pod(qq|call $name function. Expects no params.|)
337             ->example(qq|$name()|);
338 13         204 return $meta;
339              
340             }
341              
342             sub build_sub_code {
343 27     27 1 5652 my ( $self, $name, $params, $subtype, $code ) = @_;
344 27 100 66     115 if ( !defined($name) || ref $name ) {
345 2 50       6 $name = defined $name ? $name : 'undef';
346 2         21 die
347             qq{Str: invalid value $name for variable \$name in method build_sub_code};
348             }
349 25 100 66     85 if ( !defined($params) || ref $params ) {
350 2 50       5 $params = defined $params ? $params : 'undef';
351 2         17 die
352             qq{Str: invalid value $params for variable \$params in method build_sub_code};
353             }
354 23 100 66     74 if ( !defined($subtype) || ref $subtype ) {
355 2 50       6 $subtype = defined $subtype ? $subtype : 'undef';
356 2         17 die
357             qq{Str: invalid value $subtype for variable \$subtype in method build_sub_code};
358             }
359 21 100 66     81 if ( !defined($code) || ref $code ) {
360 2 50       6 $code = defined $code ? $code : 'undef';
361 2         17 die
362             qq{Str: invalid value $code for variable \$code in method build_sub_code};
363             }
364              
365 19         51 $params =~ s/^\s*,\s*//;
366 19 100       61 $params = qq|my ($params) = \@_;| if $params;
367 19         76 return qq|{
368             $params $subtype
369             $code;
370             }|;
371              
372             }
373              
374             sub build_sub {
375 6     6 1 1278 my ( $orig, $self, @params ) = ( 'SUPER::build_sub', @_ );
376              
377 6         36 my @res = $self->$orig(@params);
378             $params[0]->clear_tests->test(
379             $self->build_tests(
380 6         21 $params[1], $params[2]->{ $params[1] },
381             '', {%Module::Generate::CLASS}
382             )
383             );
384 6         78 $params[0]->pod(
385             qq|call $params[1] function. Expects $params[2]->{$params[1]}->{params_explanation}|
386             );
387              
388 6 50       46 return wantarray ? @res : $res[0];
389             }
390              
391             sub build_clearer {
392 14     14 1 2988 my ( $self, $mg, $name, $meta ) = @_;
393 14 100 100     95 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
394 2 50       6 $mg = defined $mg ? $mg : 'undef';
395 2         18 die
396             qq{Object: invalid value $mg for variable \$mg in method build_clearer};
397             }
398 12 100 66     55 if ( !defined($name) || ref $name ) {
399 2 50       7 $name = defined $name ? $name : 'undef';
400 2         16 die
401             qq{Str: invalid value $name for variable \$name in method build_clearer};
402             }
403 10 100 100     51 if ( ( ref($meta) || "" ) ne "HASH" ) {
404 2 50       7 $meta = defined $meta ? $meta : 'undef';
405 2         16 die
406             qq{HashRef: invalid value $meta for variable \$meta in method build_clearer};
407             }
408              
409 8         69 my %class = %Module::Generate::CLASS;
410 8         47 $mg->sub(qq|clear_$name|)->code(
411             qq|{
412             delete \$ACCESSORS{$name};
413             return 1;
414             }|
415             )->pod(qq|clear $name accessor function.|)
416             ->example(qq|clear_$name()|)->clear_tests->test(
417             [ 'ok', qq|$class{CURRENT}{NAME}::clear_$name| ],
418             [ 'is', qq|$class{CURRENT}{NAME}::$name|, 'undef' ]
419             );
420              
421             }
422              
423             sub build_predicate {
424 11     11 1 2951 my ( $self, $mg, $name, $meta ) = @_;
425 11 100 100     92 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
426 2 50       6 $mg = defined $mg ? $mg : 'undef';
427 2         17 die
428             qq{Object: invalid value $mg for variable \$mg in method build_predicate};
429             }
430 9 100 66     40 if ( !defined($name) || ref $name ) {
431 2 50       7 $name = defined $name ? $name : 'undef';
432 2         15 die
433             qq{Str: invalid value $name for variable \$name in method build_predicate};
434             }
435 7 100 100     31 if ( ( ref($meta) || "" ) ne "HASH" ) {
436 2 50       6 $meta = defined $meta ? $meta : 'undef';
437 2         27 die
438             qq{HashRef: invalid value $meta for variable \$meta in method build_predicate};
439             }
440              
441 5         20 my %class = %Module::Generate::CLASS;
442             $mg->sub(qq|has_$name|)->code(
443             qq|{
444             return exists \$ACCESSORS{$name};
445             }|
446             )
447             ->pod(
448             qq|has_$name accessor function will return trye if $name accessor has a value.|
449             )->example(qq|has_$name()|)->clear_tests->test(
450             ( $meta->{$name}->{required} || $meta->{$name}->{default}
451             ? ( [ 'is', qq|$class{CURRENT}{NAME}::has_$name|, 1 ], )
452             : ( [ 'is', qq|$class{CURRENT}{NAME}::has_$name|, q|''| ], )
453             ),
454 5 50 66     23 $self->build_tests( $name, $meta->{$name}, '', \%class ),
455             [ 'is', qq|$class{CURRENT}{NAME}::has_$name|, 1 ],
456             );
457              
458             }
459              
460             sub build_coerce {
461 35     35 1 3355 my ( $self, $name, $param, $code ) = @_;
462 35 100 66     170 if ( !defined($name) || ref $name ) {
463 2 50       7 $name = defined $name ? $name : 'undef';
464 2         26 die
465             qq{Str: invalid value $name for variable \$name in method build_coerce};
466             }
467 33 100 66     120 if ( !defined($param) || ref $param ) {
468 2 50       6 $param = defined $param ? $param : 'undef';
469 2         16 die
470             qq{Str: invalid value $param for variable \$param in method build_coerce};
471             }
472 31 100       73 if ( defined $code ) {
473 2 50       6 if ( ref $code ) {
474 2         16 die
475             qq{Optional[Str]: invalid value $code for variable \$code in method build_coerce};
476             }
477             }
478              
479             return
480 29 0       157 defined $code
    50          
481             ? $code =~ m/^\w+$/
482             ? qq|$param = $code($param);|
483             : $code
484             : q||;
485              
486             }
487              
488             sub build_trigger {
489 30     30 1 18248 my ( $self, $name, $param, $code ) = @_;
490 30 100 66     156 if ( !defined($name) || ref $name ) {
491 2 50       6 $name = defined $name ? $name : 'undef';
492 2         17 die
493             qq{Str: invalid value $name for variable \$name in method build_trigger};
494             }
495 28 100 66     109 if ( !defined($param) || ref $param ) {
496 2 50       5 $param = defined $param ? $param : 'undef';
497 2         16 die
498             qq{Str: invalid value $param for variable \$param in method build_trigger};
499             }
500 26 100       53 if ( defined $code ) {
501 2 50       6 if ( ref $code ) {
502 2         16 die
503             qq{Optional[Str]: invalid value $code for variable \$code in method build_trigger};
504             }
505             }
506              
507             return
508 24 0       75 defined $code
    0          
    50          
509             ? $code =~ m/^1$/
510             ? qq|_trigger_$name|
511             : $code =~ m/^\w+$/ ? qq|$code($param);|
512             : $code
513             : q||;
514              
515             }
516              
517             sub build_tests {
518 73     73 1 9276 my ( $self, $name, $meta, $mod, $class ) = @_;
519 73 100 66     297 if ( !defined($name) || ref $name ) {
520 2 50       7 $name = defined $name ? $name : 'undef';
521 2         16 die
522             qq{Str: invalid value $name for variable \$name in method build_tests};
523             }
524 71 100 100     232 if ( ( ref($meta) || "" ) ne "HASH" ) {
525 2 50       5 $meta = defined $meta ? $meta : 'undef';
526 2         16 die
527             qq{HashRef: invalid value $meta for variable \$meta in method build_tests};
528             }
529 69 100       137 if ( defined $mod ) {
530 37 100       77 if ( ref $mod ) {
531 2         18 die
532             qq{Optional[Str]: invalid value $mod for variable \$mod in method build_tests};
533             }
534             }
535 67 100       112 if ( defined $class ) {
536 37 100 100     99 if ( ( ref($class) || "" ) ne "HASH" ) {
537 2         15 die
538             qq{Optional[HashRef]: invalid value $class for variable \$class in method build_tests};
539             }
540             }
541              
542 65         100 my @tests;
543 65 100       125 if ($class) {
544 35         59 my $cls = $class->{CURRENT}->{NAME};
545 35 100       97 if ( $meta->{meta} eq 'ACCESSOR' ) {
    50          
546             $meta->{private}
547             ? do {
548 8         28 push @tests,
549             [
550             'eval',
551             qq|${cls}::${name}()|,
552             'private method|private attribute'
553             ];
554             }
555 29 100       60 : do {
556             push @tests, [ 'is', qq|${cls}::${name}()|, 'undef' ]
557 21 100 100     103 if !$meta->{required} && !$meta->{default};
558 21         63 push @tests, [ 'eval', qq|${cls}::${name}()|, q|^$| ];
559             my (@test_cases)
560 21   100     89 = $self->build_test_data( $meta->{type}->[0] || 'Any',
561             $name );
562 21 100       14314 if ( scalar @test_cases > 1 ) {
563 18         38 my $valid = shift @test_cases;
564 18         76 push @tests,
565             [ 'deep', qq|${cls}::${name}($valid)|, $valid ];
566 18 50       83 unless ( $meta->{coerce} ) {
567 18         40 for (@test_cases) {
568 95         258 push @tests,
569             [
570             'eval', qq|${cls}::${name}($_)|,
571             'invalid|value|type|constraint|greater|atleast'
572             ];
573             }
574             }
575 18         64 push @tests, [ 'deep', qq|${cls}::${name}|, $valid ];
576             }
577             };
578             }
579             elsif ( $meta->{meta} eq 'METHOD' ) {
580             $meta->{private}
581             ? do {
582 0         0 push @tests,
583             [ 'eval', qq|${cls}::${name}()|, 'private method' ];
584             }
585 6 50 66     25 : $meta->{param} && do {
586             my %test_data = map {
587             $_ => [
588             $self->build_test_data(
589             $meta->{params_map}->{$_}->{type} || 'Any', $name
590             ),
591             ( $meta->{params_map}->{$_}->{type} || 'Any' )
592             !~ m/^(|Optional|Any|Item)/ ? q|undef| : ()
593             ]
594             } @{ $meta->{param} };
595             for my $key ( @{ $meta->{param} } ) {
596             for my $ah ( splice @{ $test_data{$key} }, 1 ) {
597             push @tests,
598             [
599             'eval',
600             sprintf(
601             q|%s::%s(%s)|,
602             $cls, $name,
603             join ', ',
604             map { $key eq $_ ? $ah : $test_data{$_}->[0] }
605             @{ $meta->{param} }
606             ),
607             'invalid|value|type|constraint|greater|atleast'
608             ];
609             }
610             }
611             }
612             }
613             }
614 65 100       147 push @tests, @{ $meta->{test} } if $meta->{test};
  2         4  
615 65         254 return @tests;
616              
617             }
618              
619             1;
620              
621             __END__
622              
623             =head1 NAME
624              
625             Hades::Realm::Exporter - Hades realm for Exporter
626              
627             =head1 VERSION
628              
629             Version 0.01
630              
631             =cut
632              
633             =head1 SYNOPSIS
634              
635             Quick summary of what the module does:
636              
637             Hades->run({
638             eval => 'Kosmos {
639             [curae penthos] :t(Int) :d(2) :p :pr :c :r :i(1, GROUP)
640             geras $nosoi :t(Int) :d(5) :i { if (penthos() == $nosoi) { return curae; } }
641             }',
642             realm => 'Exporter',
643             });
644              
645             ... generates ...
646              
647             package Kosmos;
648             use strict;
649             use warnings;
650             use Exporter qw/import/;
651             our $VERSION = 0.01;
652             our ( @EXPORT, @EXPORT_OK, %EXPORT_TAGS, %ACCESSORS );
653              
654             BEGIN {
655             @EXPORT = (
656             'curae', 'has_curae', 'clear_curae', 'penthos',
657             'has_penthos', 'clear_penthos'
658             );
659             @EXPORT_OK = (
660             'curae', 'has_curae', 'clear_curae', 'penthos',
661             'has_penthos', 'clear_penthos', 'geras'
662             );
663             %EXPORT_TAGS = (
664             'METHODS' => ['geras'],
665             'CLEARERS' => [ 'clear_curae', 'clear_penthos' ],
666             'GROUP' => [ 'curae', 'penthos' ],
667             'PREDICATES' => [ 'has_curae', 'has_penthos' ],
668             'ACCESSORS' => [ 'curae', 'penthos' ]
669             );
670             %ACCESSORS = ( curae => 2, penthos => 2, );
671             }
672              
673             sub curae {
674             my ($value) = @_;
675             my $private_caller = caller();
676             if ( $private_caller ne __PACKAGE__ ) {
677             die "cannot call private method curae from $private_caller";
678             }
679             if ( defined $value ) {
680             if ( ref $value || $value !~ m/^[-+\d]\d*$/ ) {
681             die qq{Int: invalid value $value for accessor curae};
682             }
683             $ACCESSORS{curae} = $value;
684             }
685             return $ACCESSORS{curae};
686             }
687              
688             sub has_curae {
689             return exists $ACCESSORS{curae};
690             }
691              
692             sub clear_curae {
693             delete $ACCESSORS{curae};
694             return 1;
695             }
696              
697             sub penthos {
698             my ($value) = @_;
699             my $private_caller = caller();
700             if ( $private_caller ne __PACKAGE__ ) {
701             die "cannot call private method penthos from $private_caller";
702             }
703             if ( defined $value ) {
704             if ( ref $value || $value !~ m/^[-+\d]\d*$/ ) {
705             die qq{Int: invalid value $value for accessor penthos};
706             }
707             $ACCESSORS{penthos} = $value;
708             }
709             return $ACCESSORS{penthos};
710             }
711              
712             sub has_penthos {
713             return exists $ACCESSORS{penthos};
714             }
715              
716             sub clear_penthos {
717             delete $ACCESSORS{penthos};
718             return 1;
719             }
720              
721             sub geras {
722             my ($nosoi) = @_;
723             $nosoi = defined $nosoi ? $nosoi : 5;
724             if ( !defined($nosoi) || ref $nosoi || $nosoi !~ m/^[-+\d]\d*$/ ) {
725             $nosoi = defined $nosoi ? $nosoi : 'undef';
726             die
727             qq{Int: invalid value $nosoi for variable \$nosoi in method geras};
728             }
729             if ( penthos() == $nosoi ) { return curae(); }
730             }
731              
732             1;
733              
734             __END__
735              
736             =head1 SUBROUTINES/METHODS
737              
738             =head2 new
739              
740             Instantiate a new Hades::Realm::Exporter object.
741              
742             Hades::Realm::Exporter->new
743              
744             =head2 build_self
745              
746             call build_self method. Expects param $name to be a Optional[Str].
747              
748             $obj->build_self($name)
749              
750             =head2 default_export_hash
751              
752             call default_export_hash method. Expects param $mg to be a Object, param $class to be a HashRef, param $export to be a HashRef.
753              
754             $obj->default_export_hash($mg, $class, $export)
755              
756             =head2 build_new
757              
758             call build_new method. Expects param $mg to be a Object, param $meta to be a HashRef, param $our to be any value including undef.
759              
760             $obj->build_new($mg, $meta, $our)
761              
762             =head2 build_exporter
763              
764             call build_exporter method. Expects param $begin to be a Str, param $mg to be a Object, param $export to be a HashRef, param $meta to be a HashRef.
765              
766             $obj->build_exporter($begin, $mg, $export, $meta)
767              
768             =head2 build_export_tags
769              
770             call build_export_tags method. Expects param $name to be a Str, param $type to be a Str, param $export to be a HashRef, param $now to be a Optional[Int], param $import to be a ArrayRef.
771              
772             $obj->build_export_tags($name, $type, $export, $now, $import)
773              
774             =head2 after_class
775              
776             call after_class method. Expects param $mg to be a Object.
777              
778             $obj->after_class($mg)
779              
780             =head2 build_sub_or_accessor_attributes
781              
782             call build_sub_or_accessor_attributes method.
783              
784             =head2 build_accessor_no_arguments
785              
786             call build_accessor_no_arguments method. Expects param $mg to be any value including undef, param $token to be any value including undef, param $meta to be any value including undef.
787              
788             $obj->build_accessor_no_arguments($mg, $token, $meta)
789              
790             =head2 build_accessor_code
791              
792             call build_accessor_code method. Expects param $name to be a Str, param $private to be a Str, param $type to be a Str, param $trigger to be a Str.
793              
794             $obj->build_accessor_code($name, $private, $type, $trigger)
795              
796             =head2 build_accessor
797              
798             call build_accessor method.
799              
800             =head2 build_modify
801              
802             call build_modify method. Expects no params.
803              
804             $obj->build_modify()
805              
806             =head2 build_sub_no_arguments
807              
808             call build_sub_no_arguments method. Expects param $mg to be any value including undef, param $token to be any value including undef, param $meta to be any value including undef.
809              
810             $obj->build_sub_no_arguments($mg, $token, $meta)
811              
812             =head2 build_sub_code
813              
814             call build_sub_code method. Expects param $name to be a Str, param $params to be a Str, param $subtype to be a Str, param $code to be a Str.
815              
816             $obj->build_sub_code($name, $params, $subtype, $code)
817              
818             =head2 build_sub
819              
820             call build_sub method.
821              
822             =head2 build_clearer
823              
824             call build_clearer method. Expects param $mg to be a Object, param $name to be a Str, param $meta to be a HashRef.
825              
826             $obj->build_clearer($mg, $name, $meta)
827              
828             =head2 build_predicate
829              
830             call build_predicate method. Expects param $mg to be a Object, param $name to be a Str, param $meta to be a HashRef.
831              
832             $obj->build_predicate($mg, $name, $meta)
833              
834             =head2 build_coerce
835              
836             call build_coerce method. Expects param $name to be a Str, param $param to be a Str, param $code to be a Optional[Str].
837              
838             $obj->build_coerce($name, $param, $code)
839              
840             =head2 build_trigger
841              
842             call build_trigger method. Expects param $name to be a Str, param $param to be a Str, param $code to be a Optional[Str].
843              
844             $obj->build_trigger($name, $param, $code)
845              
846             =head2 build_tests
847              
848             call build_tests method. Expects param $name to be a Str, param $meta to be a HashRef, param $mod to be a Optional[Str], param $class to be a Optional[HashRef].
849              
850             $obj->build_tests($name, $meta, $mod, $class)
851              
852             =head1 ACCESSORS
853              
854             =head2 export
855              
856             get or set export.
857              
858             $obj->export;
859              
860             $obj->export($value);
861              
862             =head1 AUTHOR
863              
864             LNATION, C<< <email at lnation.org> >>
865              
866             =head1 BUGS
867              
868             Please report any bugs or feature requests to C<bug-hades::realm::exporter at rt.cpan.org>, or through
869             the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Hades-Realm-Exporter>. I will be notified, and then you'll
870             automatically be notified of progress on your bug as I make changes.
871              
872             =head1 SUPPORT
873              
874             You can find documentation for this module with the perldoc command.
875              
876             perldoc Hades::Realm::Exporter
877              
878             You can also look for information at:
879              
880             =over 4
881              
882             =item * RT: CPAN's request tracker (report bugs here)
883              
884             L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Hades-Realm-Exporter>
885              
886             =item * AnnoCPAN: Annotated CPAN documentation
887              
888             L<http://annocpan.org/dist/Hades-Realm-Exporter>
889              
890             =item * CPAN Ratings
891              
892             L<https://cpanratings.perl.org/d/Hades-Realm-Exporter>
893              
894             =item * Search CPAN
895              
896             L<https://metacpan.org/release/Hades-Realm-Exporter>
897              
898             =back
899              
900             =head1 ACKNOWLEDGEMENTS
901              
902             =head1 LICENSE AND COPYRIGHT
903              
904             This software is Copyright (c) 2020 by LNATION.
905              
906             This is free software, licensed under:
907              
908             The Artistic License 2.0 (GPL Compatible)
909              
910             =cut
911              
912