| 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 | 2 2 2 | 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 | 34 | 0 | my ( $args, $slurpy_name, $arg_name ) = @_; | ||||
| 51 | |||||||
| 52 | 34 | 0 | return if !exists $args->{$arg_name} and $slurpy_name ne $arg_name; | ||||
| 53 | |||||||
| 54 | 16 | 0 | return ( $arg_name => $args->{$arg_name} ); | ||||
| 55 | } | ||||||
| 56 | |||||||
| 57 | sub _find_slurpy_attr { | ||||||
| 58 | 10 | 0 | my ( $class ) = @_; | ||||
| 59 | |||||||
| 60 | # find all attributes marked slurpy | ||||||
| 61 | 34 | 0 | my @slurpy_attrs = | ||||
| 62 | 10 | 0 | grep { $_->slurpy } | ||||
| 63 | $class->meta->get_all_attributes; | ||||||
| 64 | |||||||
| 65 | # and ensure that we have one | ||||||
| 66 | 10 | 0 | my $slurpy_attr = shift @slurpy_attrs; | ||||
| 67 | |||||||
| 68 | 10 | 0 | Moose->throw_error( "No parameters marked 'slurpy', do you need this module?" ) if !defined $slurpy_attr; | ||||
| 69 | 10 | 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 | 10 | 0 | return $slurpy_attr; | ||||
| 72 | } | ||||||
| 73 | |||||||
| 74 | 2 2 2 | 0 0 0 | no Moose::Role; | ||||
| 75 | |||||||
| 76 | 1; | ||||||
| 77 | |||||||