File Coverage

blib/lib/Hades/Realm/OO.pm
Criterion Covered Total %
statement 219 332 65.9
branch 145 278 52.1
condition 104 167 62.2
subroutine 35 46 76.0
pod 35 35 100.0
total 538 858 62.7


line stmt bran cond sub pod time code
1             package Hades::Realm::OO;
2 2     2   140101 use strict;
  2         15  
  2         59  
3 2     2   11 use warnings;
  2         4  
  2         73  
4 2     2   15 use base qw/Hades/;
  2         4  
  2         1552  
5             our $VERSION = 0.05;
6              
7             sub new {
8 53 100   53 1 108527 my ( $cls, %args ) = ( shift(), scalar @_ == 1 ? %{ $_[0] } : @_ );
  52         201  
9 53         210 my $self = $cls->SUPER::new(%args);
10 53         546 my %accessors = ( current_class => {}, meta => {}, is_role => {}, );
11 53         160 for my $accessor ( keys %accessors ) {
12             my $param
13             = defined $args{$accessor}
14             ? $args{$accessor}
15 143 100       302 : $accessors{$accessor}->{default};
16             my $value
17             = $self->$accessor( $accessors{$accessor}->{builder}
18 143 50       414 ? $accessors{$accessor}->{builder}->( $self, $param )
19             : $param );
20 127 50 33     386 unless ( !$accessors{$accessor}->{required} || defined $value ) {
21 0         0 die "$accessor accessor is required";
22             }
23             }
24 37         318 return $self;
25             }
26              
27             sub current_class {
28 51     51 1 1326 my ( $self, $value ) = @_;
29 51 100       142 if ( defined $value ) {
30 13 100       29 if ( ref $value ) {
31 4         61 die qq{Str: invalid value $value for accessor current_class};
32             }
33 9         36 $self->{current_class} = $value;
34             }
35 47         163 return $self->{current_class};
36             }
37              
38             sub meta {
39 67     67 1 7826 my ( $self, $value ) = @_;
40 67 100       145 if ( defined $value ) {
41 29 100 100     95 if ( ( ref($value) || "" ) ne "HASH" ) {
42 4         54 die
43             qq{Map[Str, Dict[types => HashRef, attributes => HashRef]]: invalid value $value for accessor meta};
44             }
45 25         36 for my $key ( keys %{$value} ) {
  25         74  
46 25         42 my $val = $value->{$key};
47 25 50       49 if ( ref $key ) {
48 0         0 die
49             qq{Map[Str, Dict[types => HashRef, attributes => HashRef]]: invalid value $key for accessor meta expected Str};
50             }
51 25 100 100     75 if ( ( ref($val) || "" ) ne "HASH" ) {
52 6 100       19 $val = defined $val ? $val : 'undef';
53 6         60 die
54             qq{Map[Str, Dict[types => HashRef, attributes => HashRef]]: invalid value $val for accessor meta expected Dict[types=>HashRef,attributes=>HashRef]};
55             }
56 19 100 100     71 if ( ( ref( $val->{types} ) || "" ) ne "HASH" ) {
57             $val->{types}
58 8 100       38 = defined $val->{types} ? $val->{types} : 'undef';
59 8         80 die
60             qq{Map[Str, Dict[types => HashRef, attributes => HashRef]]: invalid value $val->{types} for accessor meta expected Dict[types=>HashRef,attributes=>HashRef] expected HashRef for types};
61             }
62 11 100 100     44 if ( ( ref( $val->{attributes} ) || "" ) ne "HASH" ) {
63             $val->{attributes}
64             = defined $val->{attributes}
65             ? $val->{attributes}
66 6 100       20 : 'undef';
67 6         69 die
68             qq{Map[Str, Dict[types => HashRef, attributes => HashRef]]: invalid value $val->{attributes} for accessor meta expected Dict[types=>HashRef,attributes=>HashRef] expected HashRef for attributes};
69             }
70             }
71 5         11 $self->{meta} = $value;
72             }
73 43         103 return $self->{meta};
74             }
75              
76             sub is_role {
77 52     52 1 1317 my ( $self, $value ) = @_;
78 52 100       121 if ( defined $value ) {
79 13         22 my $ref = ref $value;
80 13 50 100     128 if ( ( $ref || 'SCALAR' ) ne 'SCALAR'
    100 66        
81             || ( $ref ? $$value : $value ) !~ m/^(1|0)$/ )
82             {
83 4         52 die qq{Bool: invalid value $value for accessor is_role};
84             }
85 9 50       23 $value = !!( $ref ? $$value : $value ) ? 1 : 0;
    50          
86 9         20 $self->{is_role} = $value;
87             }
88 48         108 return $self->{is_role};
89             }
90              
91             sub clear_is_role {
92 1     1 1 3 my ($self) = @_;
93 1         3 delete $self->{is_role};
94 1         4 return $self;
95             }
96              
97             sub module_generate {
98 2     2 1 629 my ( $self, $mg ) = @_;
99 2 50 100     22 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
100 2 50       9 $mg = defined $mg ? $mg : 'undef';
101 2         19 die
102             qq{Object: invalid value $mg for variable \$mg in method module_generate};
103             }
104              
105             $mg->keyword(
106             'has',
107 0     0   0 CODE => sub { $self->build_has(@_) },
108 0         0 KEYWORDS => $self->build_has_keywords,
109             POD_TITLE => 'ATTRIBUTES',
110             POD_POD => 'Get or set $keyword',
111             POD_EXAMPLE => "\$obj->\$keyword;\n\n\t\$obj->\$keyword(\$value)"
112             );
113             $mg->keyword(
114             'extends',
115 0     0   0 CODE => sub { $self->build_extends(@_) },
116 0         0 KEYWORDS => $self->build_extends_keywords,
117             POD_TITLE => 'EXTENDS',
118             POD_POD => 'This class extends the following classes',
119             POD_EXAMPLE => "\$keyword"
120             );
121             $mg->keyword(
122             'with',
123 0     0   0 CODE => sub { $self->build_with(@_) },
124 0         0 KEYWORDS => $self->build_with_keywords,
125             POD_TITLE => 'WITH',
126             POD_POD => 'This class includes the following roles',
127             POD_EXAMPLE => "\$keyword"
128             );
129             $mg->keyword(
130             'requires',
131 0     0   0 CODE => sub { $self->build_requires(@_) },
132 0         0 KEYWORDS => $self->build_requires_keywords,
133             POD_TITLE => 'REQUIRES',
134             POD_POD => 'This class requires:',
135             POD_EXAMPLE => "\$keyword"
136             );
137             $mg->keyword(
138             'before',
139 0     0   0 CODE => sub { $self->build_before(@_) },
140 0         0 KEYWORDS => $self->build_before_keywords,
141             POD_TITLE => 'BEFORE',
142             POD_POD => 'Call $keyword method',
143             POD_EXAMPLE => "\$obj->\$keyword"
144             );
145             $mg->keyword(
146             'around',
147 0     0   0 CODE => sub { $self->build_around(@_) },
148 0         0 KEYWORDS => $self->build_around_keywords,
149             POD_TITLE => 'AROUND',
150             POD_POD => 'Call $keyword method',
151             POD_EXAMPLE => "\$obj->\$keyword"
152             );
153             $mg->keyword(
154             'after',
155 0     0   0 CODE => sub { $self->build_after(@_) },
156 0         0 KEYWORDS => $self->build_after_keywords,
157             POD_TITLE => 'AFTER',
158             POD_POD => 'Call $keyword method',
159             POD_EXAMPLE => "\$obj->\$keyword"
160             );
161              
162             }
163              
164             sub build_class_inheritance {
165 0     0 1 0 my ( $orig, $self, @params ) = ( 'SUPER::build_class_inheritance', @_ );
166              
167 0 0 0     0 if ( $params[-1] =~ m/^(role)$/i ) {
    0          
    0          
168 0         0 $self->is_role(1);
169 0         0 return $params[-2];
170             }
171             elsif ( $params[-1] =~ m/^(with|extends|parent|base)$/ ) {
172 0 0       0 return 'extends' if $1 =~ m/parent|base/;
173 0         0 return $params[-1];
174             }
175             elsif ( $params[-2] && $params[-2] =~ m/^(with|extends)$/ ) {
176 0         0 my ( $mg, $last, $ident ) = splice @params, -3;
177 0         0 $mg->$last($ident);
178 0         0 return $last;
179             }
180 0         0 my @res = $self->$orig(@params);
181 0 0       0 return wantarray ? @res : $res[0];
182             }
183              
184             sub build_new {
185 6     6 1 3242 my ( $self, $mg, $meta, $types ) = @_;
186 6 100 100     52 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
187 2 50       7 $mg = defined $mg ? $mg : 'undef';
188 2         21 die
189             qq{Object: invalid value $mg for variable \$mg in method build_new};
190             }
191 4 100 100     20 if ( ( ref($meta) || "" ) ne "HASH" ) {
192 2 50       7 $meta = defined $meta ? $meta : 'undef';
193 2         19 die
194             qq{HashRef: invalid value $meta for variable \$meta in method build_new};
195             }
196 2 50       6 $types = defined $types ? $types : {};
197 2 50 100     11 if ( ( ref($types) || "" ) ne "HASH" ) {
198 2 50       5 $types = defined $types ? $types : 'undef';
199 2         20 die
200             qq{HashRef: invalid value $types for variable \$types in method build_new};
201             }
202              
203 0         0 my %class = %Module::Generate::CLASS;
204 0         0 my %accessors = ();
205             map {
206 0         0 my $key = $_;
207             exists $meta->{$key}->{$_}
208 0         0 && do { $accessors{$key}->{$_} = $meta->{$key}->{$_} }
209 0   0     0 for ( @{ $self->build_has_keywords } );
  0         0  
210             } grep {
211             $self->unique_types( $meta->{$_}->{type}, $types )
212 0 0       0 if $meta->{$_}->{type};
213 0         0 $meta->{$_}->{meta} eq 'ACCESSOR';
214 0         0 } keys %{$meta};
  0         0  
215 0         0 my $class_meta = $self->meta;
216             $class_meta->{ $class{CURRENT}{NAME} } = {
217 0         0 types => $types,
218             attributes => \%accessors
219             };
220 0         0 $self->meta($class_meta);
221 0         0 $self->current_class( $class{CURRENT}{NAME} );
222 0         0 $class{CURRENT}{SUBS}{new}{NO_CODE} = 1;
223             $class{CURRENT}{SUBS}{new}{TEST}
224 0         0 = [ $self->build_tests( 'new', $meta, 'new', \%class ) ];
225              
226             }
227              
228             sub build_clearer {
229 0     0 1 0 my ( $orig, $self, @params ) = ( 'SUPER::build_clearer', @_ );
230 0         0 my @res = $self->$orig(@params);
231 0         0 $res[0]->no_code(1);
232              
233 0 0       0 return wantarray ? @res : $res[0];
234             }
235              
236             sub build_predicate {
237 0     0 1 0 my ( $orig, $self, @params ) = ( 'SUPER::build_predicate', @_ );
238 0         0 my @res = $self->$orig(@params);
239 0         0 $res[0]->no_code(1);
240              
241 0 0       0 return wantarray ? @res : $res[0];
242             }
243              
244             sub build_accessor_no_arguments {
245 6     6 1 3285 my ( $self, $mg, $token, $meta ) = @_;
246 6 100 100     50 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
247 2 50       7 $mg = defined $mg ? $mg : 'undef';
248 2         19 die
249             qq{Object: invalid value $mg for variable \$mg in method build_accessor_no_arguments};
250             }
251 4 100 100     29 if ( !defined($token) || ( ref($token) || "" ) ne "ARRAY" ) {
      66        
252 2 50       10 $token = defined $token ? $token : 'undef';
253 2         21 die
254             qq{ArrayRef: invalid value $token for variable \$token in method build_accessor_no_arguments};
255             }
256 2 50 100     21 if ( ( ref($meta) || "" ) ne "HASH" ) {
257 2 50       6 $meta = defined $meta ? $meta : 'undef';
258 2         25 die
259             qq{HashRef: invalid value $meta for variable \$meta in method build_accessor_no_arguments};
260             }
261              
262 0         0 $meta->{ $token->[0] }->{meta} = 'ACCESSOR';
263 0         0 $mg->has( $token->[0] );
264 0         0 return $meta;
265              
266             }
267              
268             sub build_accessor {
269 6     6 1 3307 my ( $self, $mg, $name, $meta ) = @_;
270 6 100 100     51 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
271 2 50       7 $mg = defined $mg ? $mg : 'undef';
272 2         20 die
273             qq{Object: invalid value $mg for variable \$mg in method build_accessor};
274             }
275 4 100 66     47 if ( !defined($name) || ref $name ) {
276 2 50       10 $name = defined $name ? $name : 'undef';
277 2         22 die
278             qq{Str: invalid value $name for variable \$name in method build_accessor};
279             }
280 2 50 100     12 if ( ( ref($meta) || "" ) ne "HASH" ) {
281 2 50       6 $meta = defined $meta ? $meta : 'undef';
282 2         20 die
283             qq{HashRef: invalid value $meta for variable \$meta in method build_accessor};
284             }
285              
286 0         0 $mg->has($name);
287             $meta->{$name}->{$_} and $mg->$_(
288             $self->build_code(
289             $mg,
290             $name,
291             $self->can("build_accessor_${_}")
292             ? $self->can("build_accessor_${_}")
293             ->( $self, $name, $meta->{$name}->{$_} )
294             : $meta->{$name}->{$_}
295             )
296 0 0 0     0 ) for ( @{ $self->build_has_keywords } );
  0         0  
297             $mg->isa(
298             $self->can("build_accessor_isa")
299             ? $self->can("build_accessor_isa")
300             ->( $self, $name, $meta->{$name}->{type}->[0] )
301             : $meta->{$name}->{type}->[0]
302 0 0       0 ) if !$meta->{$name}->{isa};
    0          
303 0         0 $mg->clear_tests->test( $self->build_tests( $name, $meta->{$name} ) );
304             $meta->{$name}->{$_}
305             && $mg->$_( $self->replace_pe_string( $meta->{$name}->{$_}, $name ) )
306 0   0     0 for qw/pod example/;
307              
308             }
309              
310             sub build_modify {
311 6     6 1 3552 my ( $self, $mg, $name, $meta ) = @_;
312 6 100 100     49 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
313 2 50       7 $mg = defined $mg ? $mg : 'undef';
314 2         19 die
315             qq{Object: invalid value $mg for variable \$mg in method build_modify};
316             }
317 4 100 66     28 if ( !defined($name) || ref $name ) {
318 2 50       7 $name = defined $name ? $name : 'undef';
319 2         20 die
320             qq{Str: invalid value $name for variable \$name in method build_modify};
321             }
322 2 50 100     11 if ( ( ref($meta) || "" ) ne "HASH" ) {
323 2 50       10 $meta = defined $meta ? $meta : 'undef';
324 2         19 die
325             qq{HashRef: invalid value $meta for variable \$meta in method build_modify};
326             }
327              
328             $meta->{$name}->{$_}
329             && $mg->$_($name)
330             ->code( $self->build_code( $mg, $name, delete $meta->{$name}->{$_} ) )
331             ->test( $self->build_tests( $name, $meta->{$name} ) )
332 0   0     0 for qw/before around after/;
333             $meta->{$name}->{$_}
334             && $mg->$_(
335             $self->replace_pe_string( delete $meta->{$name}->{$_}, $name ) )
336 0   0     0 for qw/pod example/;
337              
338             }
339              
340             sub after_class {
341 4     4 1 1939 my ( $self, $mg, $meta ) = @_;
342 4 100 100     39 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
343 2 50       7 $mg = defined $mg ? $mg : 'undef';
344 2         19 die
345             qq{Object: invalid value $mg for variable \$mg in method after_class};
346             }
347 2 50 100     15 if ( ( ref($meta) || "" ) ne "HASH" ) {
348 2 50       8 $meta = defined $meta ? $meta : 'undef';
349 2         20 die
350             qq{HashRef: invalid value $meta for variable \$meta in method after_class};
351             }
352              
353 0 0 0     0 $self->is_role && $self->clear_is_role
354             ? $self->build_as_role( $mg, $meta )
355             : $self->build_as_class( $mg, $meta );
356              
357             }
358              
359             sub unique_types {
360 3     3 1 1303 my ( $self, $type, $unique ) = @_;
361 3 50       10 if ( ref $type eq 'ARRAY' ) {
362 0         0 $self->unique_types( $_, $unique ) for @{$type};
  0         0  
363 0         0 return;
364             }
365 3 100 66     18 if ( !defined($type) || ref $type ) {
366 1 50       5 $type = defined $type ? $type : 'undef';
367 1         11 die
368             qq{Str: invalid value $type for variable \$type in method unique_types};
369             }
370 2 50 100     12 if ( ( ref($unique) || "" ) ne "HASH" ) {
371 2 50       7 $unique = defined $unique ? $unique : 'undef';
372 2         19 die
373             qq{HashRef: invalid value $unique for variable \$unique in method unique_types};
374             }
375              
376 0 0 0     0 if ( $type =~ s/^([^\[ ]+)\[(.*)\]$/$2/ ) {
    0          
377 0         0 my ( $t, $v ) = ( $1, $2 );
378 0 0       0 $unique->{$t}++ if ( $t =~ m/^\w+$/ );
379 0         0 $v =~ s/,\s*\d+,\s*\d+$//g;
380 0         0 $self->unique_types( $v, $unique );
381             }
382             elsif ( $type =~ m/^\s*\w+\s*\=\>\s*/ || $type =~ m/^([^,]+),\s*(.*)$/ ) {
383 0         0 my @matches = split ',', $type;
384 0         0 while (@matches) {
385 0         0 my ($match) = ( shift @matches );
386 0 0 0     0 if ( @matches && $match =~ m/(Map|Tuple|ArrayRef|Dict)\[/ ) {
387             my $cb = sub {
388 0     0   0 my $copy = shift;
389 0         0 1 while ( $copy =~ s/\[[^\[\]]+\]//g );
390 0 0       0 return ( $copy =~ m/\[|\]/ ) ? 1 : 0;
391 0         0 };
392 0         0 1 while ( $cb->( $match .= ', ' . shift @matches ) );
393             }
394             my ( $k, $v )
395 0 0       0 = map { my $h = $_; $h =~ s/^\s*|\s*$//g; $h; }
  0         0  
  0         0  
  0         0  
396             $match =~ m/\s+\w*\s*\=\>/
397             ? split( '=>', $match, 2 )
398             : $match;
399 0   0     0 $self->unique_types( $v || $k, $unique );
400             }
401             }
402             else {
403 0         0 $unique->{$type}++;
404             }
405              
406             }
407              
408             sub build_as_class {
409 4     4 1 2016 my ( $self, $mg, $meta ) = @_;
410 4 100 100     41 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
411 2 50       6 $mg = defined $mg ? $mg : 'undef';
412 2         21 die
413             qq{Object: invalid value $mg for variable \$mg in method build_as_class};
414             }
415 2 50 100     16 if ( ( ref($meta) || "" ) ne "HASH" ) {
416 2 50       7 $meta = defined $meta ? $meta : 'undef';
417 2         19 die
418             qq{HashRef: invalid value $meta for variable \$meta in method build_as_class};
419             }
420 0         0 return ( $mg, $meta );
421             }
422              
423             sub build_as_role {
424 4     4 1 1914 my ( $self, $mg, $meta ) = @_;
425 4 100 100     37 if ( ( ref($mg) || "" ) =~ m/^(|HASH|ARRAY|SCALAR|CODE|GLOB)$/ ) {
426 2 50       8 $mg = defined $mg ? $mg : 'undef';
427 2         27 die
428             qq{Object: invalid value $mg for variable \$mg in method build_as_role};
429             }
430 2 50 100     16 if ( ( ref($meta) || "" ) ne "HASH" ) {
431 2 50       6 $meta = defined $meta ? $meta : 'undef';
432 2         21 die
433             qq{HashRef: invalid value $meta for variable \$meta in method build_as_role};
434             }
435 0         0 return ( $mg, $meta );
436             }
437              
438             sub build_has_keywords {
439 2     2 1 689 my ( $self, $keywords ) = @_;
440 2 50       10 $keywords
441             = defined $keywords
442             ? $keywords
443             : [
444             qw/is isa required default clearer coerce predicate trigger private builder/
445             ];
446 2 50 100     19 if ( !defined($keywords) || ( ref($keywords) || "" ) ne "ARRAY" ) {
      33        
447 2 50       5 $keywords = defined $keywords ? $keywords : 'undef';
448 2         19 die
449             qq{ArrayRef: invalid value $keywords for variable \$keywords in method build_has_keywords};
450             }
451 0         0 return $keywords;
452             }
453              
454             sub build_has {
455 2     2 1 727 my ( $self, $meta ) = @_;
456 2 50 100     26 if ( ( ref($meta) || "" ) ne "HASH" ) {
457 2 50       10 $meta = defined $meta ? $meta : 'undef';
458 2         19 die
459             qq{HashRef: invalid value $meta for variable \$meta in method build_has};
460             }
461              
462 0         0 my $name = $meta->{has};
463 0         0 my $private = $self->SUPER::build_private( $name, $meta->{private} );
464             my $type = $self->SUPER::build_coerce( $name, '$value', $meta->{coerce} )
465 0         0 . $self->build_type( $name, $meta->{type}[0] );
466             my $trigger
467 0         0 = $self->SUPER::build_trigger( $name, '$value', $meta->{trigger} );
468 0         0 return qq|{
469             my ( \$self, \$value ) = \@_; $private
470             if ( defined \$value ) { $type
471             $self->{$name} = \$value; $trigger
472             }
473             return $self->{$name};
474             }|;
475              
476             }
477              
478             sub build_extends_keywords {
479 2     2 1 643 my ( $self, $keywords ) = @_;
480 2 50       6 $keywords = defined $keywords ? $keywords : [];
481 2 50 100     21 if ( !defined($keywords) || ( ref($keywords) || "" ) ne "ARRAY" ) {
      33        
482 2 50       6 $keywords = defined $keywords ? $keywords : 'undef';
483 2         19 die
484             qq{ArrayRef: invalid value $keywords for variable \$keywords in method build_extends_keywords};
485             }
486 0         0 return $keywords;
487             }
488              
489             sub build_extends {
490 2     2 1 643 my ( $self, $meta ) = @_;
491 2 50 100     13 if ( ( ref($meta) || "" ) ne "HASH" ) {
492 2 50       16 $meta = defined $meta ? $meta : 'undef';
493 2         20 die
494             qq{HashRef: invalid value $meta for variable \$meta in method build_extends};
495             }
496              
497             $meta->{extends} = '"' . $meta->{extends} . '"'
498 0 0       0 if $meta->{extends} !~ m/^["'q]/;
499 0         0 return qq(extends $meta->{extends};);
500              
501             }
502              
503             sub build_with_keywords {
504 2     2 1 652 my ( $self, $keywords ) = @_;
505 2 50       7 $keywords = defined $keywords ? $keywords : [];
506 2 50 100     17 if ( !defined($keywords) || ( ref($keywords) || "" ) ne "ARRAY" ) {
      33        
507 2 50       6 $keywords = defined $keywords ? $keywords : 'undef';
508 2         19 die
509             qq{ArrayRef: invalid value $keywords for variable \$keywords in method build_with_keywords};
510             }
511 0         0 return $keywords;
512             }
513              
514             sub build_with {
515 2     2 1 650 my ( $self, $meta ) = @_;
516 2 50 100     15 if ( ( ref($meta) || "" ) ne "HASH" ) {
517 2 50       7 $meta = defined $meta ? $meta : 'undef';
518 2         20 die
519             qq{HashRef: invalid value $meta for variable \$meta in method build_with};
520             }
521              
522 0 0       0 $meta->{with} = '"' . $meta->{with} . '"' if $meta->{with} !~ m/^["'q]/;
523 0         0 return qq(with $meta->{with};);
524              
525             }
526              
527             sub build_requires_keywords {
528 2     2 1 658 my ( $self, $keywords ) = @_;
529 2 50       7 $keywords = defined $keywords ? $keywords : [];
530 2 50 100     18 if ( !defined($keywords) || ( ref($keywords) || "" ) ne "ARRAY" ) {
      33        
531 2 50       6 $keywords = defined $keywords ? $keywords : 'undef';
532 2         26 die
533             qq{ArrayRef: invalid value $keywords for variable \$keywords in method build_requires_keywords};
534             }
535 0         0 return $keywords;
536             }
537              
538             sub build_requires {
539 2     2 1 713 my ( $self, $meta ) = @_;
540 2 50 100     16 if ( ( ref($meta) || "" ) ne "HASH" ) {
541 2 50       6 $meta = defined $meta ? $meta : 'undef';
542 2         20 die
543             qq{HashRef: invalid value $meta for variable \$meta in method build_requires};
544             }
545              
546             $meta->{requires} = '"' . $meta->{requires} . '"'
547 0 0       0 if $meta->{requires} !~ m/^["'q]/;
548 0         0 return qq(requires $meta->{requires};);
549              
550             }
551              
552             sub build_before_keywords {
553 2     2 1 660 my ( $self, $keywords ) = @_;
554 2 50       9 $keywords = defined $keywords ? $keywords : [];
555 2 50 100     21 if ( !defined($keywords) || ( ref($keywords) || "" ) ne "ARRAY" ) {
      33        
556 2 50       8 $keywords = defined $keywords ? $keywords : 'undef';
557 2         18 die
558             qq{ArrayRef: invalid value $keywords for variable \$keywords in method build_before_keywords};
559             }
560 0         0 return $keywords;
561             }
562              
563             sub build_before {
564 2     2 1 661 my ( $self, $meta ) = @_;
565 2 50 100     16 if ( ( ref($meta) || "" ) ne "HASH" ) {
566 2 50       7 $meta = defined $meta ? $meta : 'undef';
567 2         18 die
568             qq{HashRef: invalid value $meta for variable \$meta in method build_before};
569             }
570              
571             return
572 0         0 qq(before $meta->{before} => sub { my (\$orig, \$self, \@params) = \@_; $meta->{CODE} };);
573              
574             }
575              
576             sub build_around_keywords {
577 2     2 1 638 my ( $self, $keywords ) = @_;
578 2 50       7 $keywords = defined $keywords ? $keywords : [];
579 2 50 100     18 if ( !defined($keywords) || ( ref($keywords) || "" ) ne "ARRAY" ) {
      33        
580 2 50       8 $keywords = defined $keywords ? $keywords : 'undef';
581 2         20 die
582             qq{ArrayRef: invalid value $keywords for variable \$keywords in method build_around_keywords};
583             }
584 0         0 return $keywords;
585             }
586              
587             sub build_around {
588 2     2 1 734 my ( $self, $meta ) = @_;
589 2 50 100     19 if ( ( ref($meta) || "" ) ne "HASH" ) {
590 2 50       7 $meta = defined $meta ? $meta : 'undef';
591 2         21 die
592             qq{HashRef: invalid value $meta for variable \$meta in method build_around};
593             }
594              
595             return
596 0         0 qq(around $meta->{around} => sub { my (\$orig, \$self, \@params) = \@_; $meta->{CODE} };);
597              
598             }
599              
600             sub build_after_keywords {
601 2     2 1 692 my ( $self, $keywords ) = @_;
602 2 50       9 $keywords = defined $keywords ? $keywords : [];
603 2 50 100     17 if ( !defined($keywords) || ( ref($keywords) || "" ) ne "ARRAY" ) {
      33        
604 2 50       7 $keywords = defined $keywords ? $keywords : 'undef';
605 2         20 die
606             qq{ArrayRef: invalid value $keywords for variable \$keywords in method build_after_keywords};
607             }
608 0         0 return $keywords;
609             }
610              
611             sub build_after {
612 2     2 1 674 my ( $self, $meta ) = @_;
613 2 50 100     12 if ( ( ref($meta) || "" ) ne "HASH" ) {
614 2 50       6 $meta = defined $meta ? $meta : 'undef';
615 2         20 die
616             qq{HashRef: invalid value $meta for variable \$meta in method build_after};
617             }
618              
619             return
620 0         0 qq(after $meta->{after} => sub { my (\$orig, \@params) = \@_; $meta->{CODE} };);
621              
622             }
623              
624             sub build_accessor_builder {
625 4     4 1 1928 my ( $self, $name, $content ) = @_;
626 4 100 66     23 if ( !defined($name) || ref $name ) {
627 2 50       6 $name = defined $name ? $name : 'undef';
628 2         19 die
629             qq{Str: invalid value $name for variable \$name in method build_accessor_builder};
630             }
631 2 50 33     11 if ( !defined($content) || ref $content ) {
632 2 50       7 $content = defined $content ? $content : 'undef';
633 2         19 die
634             qq{Str: invalid value $content for variable \$content in method build_accessor_builder};
635             }
636              
637             return (
638 0 0       0 $content =~ m/^(\w+|1)$/
639             ? qq|$content|
640             : qq|sub {
641             my (\$self, \$value) = \@_;
642             $content
643             return \$value;
644             }|
645             );
646              
647             }
648              
649             sub build_accessor_coerce {
650 4     4 1 1954 my ( $self, $name, $content ) = @_;
651 4 100 66     22 if ( !defined($name) || ref $name ) {
652 2 50       8 $name = defined $name ? $name : 'undef';
653 2         21 die
654             qq{Str: invalid value $name for variable \$name in method build_accessor_coerce};
655             }
656 2 50 33     14 if ( !defined($content) || ref $content ) {
657 2 50       7 $content = defined $content ? $content : 'undef';
658 2         20 die
659             qq{Str: invalid value $content for variable \$content in method build_accessor_coerce};
660             }
661              
662 0 0       0 return q|sub { my ($value) = @_;|
663             . (
664             $content =~ m/^\w+$/
665             ? qq|\$value = __PACKAGE__->$content(\$value);|
666             : $content
667             ) . q|return $value; }|;
668              
669             }
670              
671             sub build_accessor_trigger {
672 4     4 1 2032 my ( $self, $name, $content ) = @_;
673 4 100 66     24 if ( !defined($name) || ref $name ) {
674 2 50       7 $name = defined $name ? $name : 'undef';
675 2         21 die
676             qq{Str: invalid value $name for variable \$name in method build_accessor_trigger};
677             }
678 2 50 33     12 if ( !defined($content) || ref $content ) {
679 2 50       8 $content = defined $content ? $content : 'undef';
680 2         20 die
681             qq{Str: invalid value $content for variable \$content in method build_accessor_trigger};
682             }
683              
684 0 0       0 return q|sub { my ($self, $value) = @_;|
685             . (
686             $content =~ m/^\w+$/
687             ? qq|\$value = \$self->$content(\$value);|
688             : $content
689             ) . q|return $value; }|;
690              
691             }
692              
693             sub build_accessor_default {
694 4     4 1 1885 my ( $self, $name, $content ) = @_;
695 4 100 66     23 if ( !defined($name) || ref $name ) {
696 2 50       6 $name = defined $name ? $name : 'undef';
697 2         20 die
698             qq{Str: invalid value $name for variable \$name in method build_accessor_default};
699             }
700 2 50 33     12 if ( !defined($content) || ref $content ) {
701 2 50       9 $content = defined $content ? $content : 'undef';
702 2         21 die
703             qq{Str: invalid value $content for variable \$content in method build_accessor_default};
704             }
705              
706 0           return q|sub {| . $content . q|}|;
707              
708             }
709              
710             1;
711              
712             __END__
713              
714             =head1 NAME
715              
716             Hades::Realm::OO - Hades realm for object orientation
717              
718             =head1 VERSION
719              
720             Version 0.01
721              
722             =cut
723              
724             =head1 SYNOPSIS
725              
726             Quick summary of what the module does:
727              
728             Hades::Realm::Kosmos base Hades::Realm::OO {
729             ...
730             }
731              
732             =head1 SUBROUTINES/METHODS
733              
734             =head2 new
735              
736             Instantiate a new Hades::Realm::OO object.
737              
738             Hades::Realm::OO->new
739              
740             =head2 clear_is_role
741              
742             clear is_role accessor
743              
744             $obj->clear_is_role
745              
746             =head2 module_generate
747              
748             call module_generate method. Expects param $mg to be a Object.
749              
750             $obj->module_generate($mg)
751              
752             =head2 build_class_inheritance
753              
754             call build_class_inheritance method.
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 $types to be a HashRef.
759              
760             $obj->build_new($mg, $meta, $types)
761              
762             =head2 build_clearer
763              
764             call build_clearer method.
765              
766             =head2 build_predicate
767              
768             call build_predicate method.
769              
770             =head2 build_accessor_no_arguments
771              
772             call build_accessor_no_arguments method. Expects param $mg to be a Object, param $token to be a ArrayRef, param $meta to be a HashRef.
773              
774             $obj->build_accessor_no_arguments($mg, $token, $meta)
775              
776             =head2 build_accessor
777              
778             call build_accessor method. Expects param $mg to be a Object, param $name to be a Str, param $meta to be a HashRef.
779              
780             $obj->build_accessor($mg, $name, $meta)
781              
782             =head2 build_modify
783              
784             call build_modify method. Expects param $mg to be a Object, param $name to be a Str, param $meta to be a HashRef.
785              
786             $obj->build_modify($mg, $name, $meta)
787              
788             =head2 after_class
789              
790             call after_class method. Expects param $mg to be a Object, param $meta to be a HashRef.
791              
792             $obj->after_class($mg, $meta)
793              
794             =head2 unique_types
795              
796             call unique_types method. Expects param $type to be a Str, param $unique to be a HashRef.
797              
798             $obj->unique_types($type, $unique)
799              
800             =head2 build_as_class
801              
802             call build_as_class method. Expects param $mg to be a Object, param $meta to be a HashRef.
803              
804             $obj->build_as_class($mg, $meta)
805              
806             =head2 build_as_role
807              
808             call build_as_role method. Expects param $mg to be a Object, param $meta to be a HashRef.
809              
810             $obj->build_as_role($mg, $meta)
811              
812             =head2 build_has_keywords
813              
814             call build_has_keywords method. Expects param $keywords to be a ArrayRef.
815              
816             $obj->build_has_keywords($keywords)
817              
818             =head2 build_has
819              
820             call build_has method. Expects param $meta to be a HashRef.
821              
822             $obj->build_has($meta)
823              
824             =head2 build_extends_keywords
825              
826             call build_extends_keywords method. Expects param $keywords to be a ArrayRef.
827              
828             $obj->build_extends_keywords($keywords)
829              
830             =head2 build_extends
831              
832             call build_extends method. Expects param $meta to be a HashRef.
833              
834             $obj->build_extends($meta)
835              
836             =head2 build_with_keywords
837              
838             call build_with_keywords method. Expects param $keywords to be a ArrayRef.
839              
840             $obj->build_with_keywords($keywords)
841              
842             =head2 build_with
843              
844             call build_with method. Expects param $meta to be a HashRef.
845              
846             $obj->build_with($meta)
847              
848             =head2 build_requires_keywords
849              
850             call build_requires_keywords method. Expects param $keywords to be a ArrayRef.
851              
852             $obj->build_requires_keywords($keywords)
853              
854             =head2 build_requires
855              
856             call build_requires method. Expects param $meta to be a HashRef.
857              
858             $obj->build_requires($meta)
859              
860             =head2 build_before_keywords
861              
862             call build_before_keywords method. Expects param $keywords to be a ArrayRef.
863              
864             $obj->build_before_keywords($keywords)
865              
866             =head2 build_before
867              
868             call build_before method. Expects param $meta to be a HashRef.
869              
870             $obj->build_before($meta)
871              
872             =head2 build_around_keywords
873              
874             call build_around_keywords method. Expects param $keywords to be a ArrayRef.
875              
876             $obj->build_around_keywords($keywords)
877              
878             =head2 build_around
879              
880             call build_around method. Expects param $meta to be a HashRef.
881              
882             $obj->build_around($meta)
883              
884             =head2 build_after_keywords
885              
886             call build_after_keywords method. Expects param $keywords to be a ArrayRef.
887              
888             $obj->build_after_keywords($keywords)
889              
890             =head2 build_after
891              
892             call build_after method. Expects param $meta to be a HashRef.
893              
894             $obj->build_after($meta)
895              
896             =head2 build_accessor_builder
897              
898             call build_accessor_builder method. Expects param $name to be a Str, param $content to be a Str.
899              
900             $obj->build_accessor_builder($name, $content)
901              
902             =head2 build_accessor_coerce
903              
904             call build_accessor_coerce method. Expects param $name to be a Str, param $content to be a Str.
905              
906             $obj->build_accessor_coerce($name, $content)
907              
908             =head2 build_accessor_trigger
909              
910             call build_accessor_trigger method. Expects param $name to be a Str, param $content to be a Str.
911              
912             $obj->build_accessor_trigger($name, $content)
913              
914             =head2 build_accessor_default
915              
916             call build_accessor_default method. Expects param $name to be a Str, param $content to be a Str.
917              
918             $obj->build_accessor_default($name, $content)
919              
920             =head1 ACCESSORS
921              
922             =head2 current_class
923              
924             get or set current_class.
925              
926             $obj->current_class;
927              
928             $obj->current_class($value);
929              
930             =head2 meta
931              
932             get or set meta.
933              
934             $obj->meta;
935              
936             $obj->meta($value);
937              
938             =head2 is_role
939              
940             get or set is_role.
941              
942             $obj->is_role;
943              
944             $obj->is_role($value);
945              
946             =head1 AUTHOR
947              
948             LNATION, C<< <email at lnation.org> >>
949              
950             =head1 BUGS
951              
952             Please report any bugs or feature requests to C<bug-hades::realm::oo at rt.cpan.org>, or through
953             the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Hades-Realm-OO>. I will be notified, and then you'll
954             automatically be notified of progress on your bug as I make changes.
955              
956             =head1 SUPPORT
957              
958             You can find documentation for this module with the perldoc command.
959              
960             perldoc Hades::Realm::OO
961              
962             You can also look for information at:
963              
964             =over 4
965              
966             =item * RT: CPAN's request tracker (report bugs here)
967              
968             L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Hades-Realm-OO>
969              
970             =item * AnnoCPAN: Annotated CPAN documentation
971              
972             L<http://annocpan.org/dist/Hades-Realm-OO>
973              
974             =item * CPAN Ratings
975              
976             L<https://cpanratings.perl.org/d/Hades-Realm-OO>
977              
978             =item * Search CPAN
979              
980             L<https://metacpan.org/release/Hades-Realm-OO>
981              
982             =back
983              
984             =head1 ACKNOWLEDGEMENTS
985              
986             =head1 LICENSE AND COPYRIGHT
987              
988             This software is Copyright (c) 2020 by LNATION.
989              
990             This is free software, licensed under:
991              
992             The Artistic License 2.0 (GPL Compatible)
993              
994             =cut
995              
996