File Coverage

blib/lib/Params/Validate/Aggregated.pm

Criterion	Covered	Total	%
statement	67	68	98.5
branch	20	24	83.3
condition	2	3	66.6
subroutine	8	9	88.8
pod	1	1	100.0
total	98	105	93.3

# --8<--8<--8<--8<--
#
# Copyright (C) 2011 Smithsonian Astrophysical Observatory
#
# This file is part of Params::Validate::Aggregated
#
# Params::Validate::Aggregated is free software: you can redistribute
# it and/or modify it under the terms of the GNU General Public
# License as published by the Free Software Foundation, either version
# 3 of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .
#
# -->8-->8-->8-->8--

package Params::Validate::Aggregated;

use strict;
use warnings;

use parent 'Exporter';

our @EXPORT_OK = qw[ pv_disagg ];
our @EXPORT_TAGS = ( all => \@EXPORT_OK );

use Params::Validate qw[ :all ];
use Data::Alias;

use Carp;

## no critic (ProhibitAccessOfPrivateData)

our $VERSION = '0.05';

sub DESTROY {}

our $AUTOLOAD;
sub AUTOLOAD {

    (my $set = $AUTOLOAD)  =~ s/.*:://;

    my $self = shift;

    croak( "unknown specification set: $set\n" )
      unless defined $self->{$set};

    return wantarray ? %{ $self->{$set} } : $self->{$set};
}

sub pv_disagg {

    my %args = validate_with( params => \@_,
                              spec => {
                                       params => { type => ARRAYREF,
                                                   optional => 0,
                                                 },
                                       spec   => { type => HASHREF,
                                                   default => {},
                                                 },
                                       with   => { type => HASHREF,
                                                   default => {},
                                                 },
                                       normalize_keys => { type => CODEREF,
                                                           optional => 1,
                                                         },
                                       allow_extra => { type => SCALAR,
                                                        optional => 1,
                                                      },
                                      },
                              allow_extra => 1
                            );

    alias my (%upar) = @{$args{params}};

    # remove the known named parameters.  the extra ones are passed
    # on to Params::Validate;
    my ( $params, $spec, $with ) = delete @args{ qw[ params spec with ] };

    # transform the "spec" parameter specifications to "with" parameter
    # specifications, adding the extra parameters
    my %with = %{$with};
    $with{$_} = { spec => $spec->{$_}, %args } for keys %$spec;

    # keep track of which input parameters were used
    my @params = keys %upar;
    my %nparams = map { $_ => $_ } @params;
    my %used   = map { $_ => 0 } @params;

    # the lists of parameter for each input spec
    my %oargs;

    # whether any input spec had the allow_extra flag set.
    my $allow_extra = 0;

    # memoize normalize_keys functions & results for the input
    # parameter set.
    my %norm;

    # for each input Params::Validate::validate_with argument list,
    #  1) track which parameters in the input parameter set are used
    #  2) create a parameter set containing only those parameters of interest

    while ( my ( $fid, $wspec ) = each %with )
    {
        my %fargs;

        my $normf = exists $wspec->{normalize_keys}
                    ? $wspec->{normalize_keys}
                    : undef;

        # normalize input parameter set keys
        my $npars;
        if ( defined $normf )
        {
            if (exists $norm{$normf} )
            {
                $npars = $norm{$normf};
            }
            else
            {
                $npars = { map { $normf->($_) => $_ } @params };
                $norm{$normf} = $npars;
            }
        }
        else
        {
            $npars = \%nparams;
        }

        my $specs = $wspec->{spec} or croak( "no specs for set $fid\n" );

        # if allow_extra is set, the entire input parameter set is legit
        if ( exists $wspec->{allow_extra} && $wspec->{allow_extra} )
        {
            $allow_extra++;

            alias +(%fargs) = (%upar);
            while ( my ( $par, $spec ) = each %$specs )
            {
                my $npar = $normf ? $normf->($par) : $par;
                $used{$npars->{$npar}}++ if exists $npars->{$npar};
            }
        }
        else
        {
            while ( my ( $par, $spec ) = each %$specs )
            {
                my $npar = $normf ? $normf->($par) : $par;
                if ( exists $npars->{$npar} )
                {
                    my $ppar = $npars->{$npar};
                    $used{$ppar}++ ;
                    alias $fargs{$ppar} = $upar{$ppar};
                }
            }
        }

        $oargs{$fid} = \%fargs;
    }

    return \%oargs, {} if $allow_extra;

    delete @upar{ grep { $used{$_} } keys %used };

    return bless(\%oargs, __PACKAGE__), \%upar;
}

1;


__END__