File Coverage

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

linestmtbrancondsubpodtimecode
1## no critic
2package 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
8around 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
49sub _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
57sub _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
761;
77