File Coverage: lib/Code/Statistics/SlurpyConstructor/Role/Object.pm

# File Coverage

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 |  |  | 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 |  |  | 34 |  | 0 | my ( $args, $slurpy_name, $arg_name ) = @_;
51 |
52 | 34 | 100 | 100 |  |  | 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 |  |  | 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 | 50 |  |  |  | 0 | Moose->throw_error( "No parameters marked 'slurpy', do you need this module?" ) if !defined $slurpy_attr;
69 | 10 | 50 |  |  |  | 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 |  |  | 2 |  | 0 0 0 | no Moose::Role;
75 |
76 |  |  |  |  |  |  | 1;
77 |