File Coverage

blib/lib/Hades/Realm/Exporter.pm
Criterion Covered Total %
statement 271 281 96.4
branch 175 236 74.1
condition 91 115 79.1
subroutine 23 25 92.0
pod 20 20 100.0
total 580 677 85.6


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