File: | lib/Code/Statistics/SlurpyConstructor/Role/Object.pm |
Coverage: | 93.1% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | ## no critic | ||||||
2 | package Code::Statistics::SlurpyConstructor::Role::Object; | ||||||
3 | |||||||
4 | # ABSTRACT: Internal class for Code::Statistics::SlurpyConstructor | ||||||
5 | |||||||
6 | 1 1 1 | 0 0 0 | use Moose::Role; | ||||
7 | |||||||
8 | around new => sub { | ||||||
9 | my ( $orig, $class, @incoming ) = @_; | ||||||
10 | |||||||
11 | my $args; | ||||||
12 | if ( scalar @incoming == 1 and ref $incoming[ 0 ] eq 'HASH' ) { | ||||||
13 | $args = shift @incoming; | ||||||
14 | } else { | ||||||
15 | $args = { @incoming }; | ||||||
16 | } | ||||||
17 | |||||||
18 | my @init_args = | ||||||
19 | grep { defined } | ||||||
20 | map { $_->init_arg } | ||||||
21 | $class->meta->get_all_attributes; | ||||||
22 | |||||||
23 | # all args initially | ||||||
24 | my %slurpy_args = %$args; | ||||||
25 | |||||||
26 | # remove any that are defined as init_args for any attributes | ||||||
27 | delete @slurpy_args{ @init_args }; | ||||||
28 | |||||||
29 | my $slurpy_attr = _find_slurpy_attr( $class ); | ||||||
30 | my $init_arg = $slurpy_attr->init_arg; | ||||||
31 | my %init_args = map _filter_final_init_arg( $args, $init_arg, $_ ), @init_args; | ||||||
32 | |||||||
33 | if ( defined $init_arg and defined $init_args{ $init_arg } ) { | ||||||
34 | my $name = $slurpy_attr->name; | ||||||
35 | die( "Can't assign to '$init_arg', as it's slurpy init_arg for attribute '$name'" ); | ||||||
36 | } | ||||||
37 | |||||||
38 | my $self = $class->$orig({ | ||||||
39 | %init_args | ||||||
40 | }); | ||||||
41 | |||||||
42 | # go behind the scenes to set the value, in case the slurpy attr | ||||||
43 | # is marked read-only. | ||||||
44 | $slurpy_attr->set_value( $self, \%slurpy_args ); | ||||||
45 | |||||||
46 | return $self; | ||||||
47 | }; | ||||||
48 | |||||||
49 | sub _filter_final_init_arg { | ||||||
50 | 17 | 0 | my ( $args, $slurpy_name, $arg_name ) = @_; | ||||
51 | |||||||
52 | 17 | 0 | return if !exists $args->{$arg_name} and $slurpy_name ne $arg_name; | ||||
53 | |||||||
54 | 8 | 0 | return ( $arg_name => $args->{$arg_name} ); | ||||
55 | } | ||||||
56 | |||||||
57 | sub _find_slurpy_attr { | ||||||
58 | 5 | 0 | my ( $class ) = @_; | ||||
59 | |||||||
60 | # find all attributes marked slurpy | ||||||
61 | 17 | 0 | my @slurpy_attrs = | ||||
62 | 5 | 0 | grep { $_->slurpy } | ||||
63 | $class->meta->get_all_attributes; | ||||||
64 | |||||||
65 | # and ensure that we have one | ||||||
66 | 5 | 0 | my $slurpy_attr = shift @slurpy_attrs; | ||||
67 | |||||||
68 | 5 | 0 | Moose->throw_error( "No parameters marked 'slurpy', do you need this module?" ) if !defined $slurpy_attr; | ||||
69 | 5 | 0 | die "Something strange here - There should never be more than a single slurpy argument, please report a bug, with test case" if @slurpy_attrs; | ||||
70 | |||||||
71 | 5 | 0 | return $slurpy_attr; | ||||
72 | } | ||||||
73 | |||||||
74 | 1 1 1 | 0 0 0 | no Moose::Role; | ||||
75 | |||||||
76 | 1; | ||||||
77 |