view release on metacpan or  search on metacpan

inc/Params/Check.pm  view on Meta::CPAN

    ### set defaults for all arguments ###
    my $defs = _hashdefs($tmpl);

    ### check if all keys are valid ###
    for my $key ( keys %$args ) {

        unless( _iskey( $key, $tmpl ) ) {
            if( $ALLOW_UNKNOWN ) {
                $defs->{$key} = $args->{$key} if exists $args->{$key};
            } else {
                _store_error(
                    loc("Key '%1' is not a valid key for %2 provided by %3",
                        $key, _who_was_it(), _who_was_it(1)),
                    $verbose
                );      
                next;
            }

        } elsif ( $tmpl->{$key}->{no_override} ) {
            _store_error(
                loc( qq[You are not allowed to override key '%1' for %2 from %3],
                    $key, _who_was_it(), _who_was_it(1)),
                $verbose
            );     
            next;
        } else {

            ### flag to set if the value was of a wrong type ###
            my $wrong;

            my $must_be_defined =   $tmpl->{$key}->{'defined'} || 
                                    $ONLY_ALLOW_DEFINED || 0;
            if( $must_be_defined ) {
                $wrong++ if not defined $args->{$key};
            }

            if( exists $tmpl->{$key}->{allow} ) {
                
                $wrong++ unless allow(  $args->{$key}, 
                                        $tmpl->{$key}->{allow},
                                        $must_be_defined,
                                    );
            }

            if( $STRICT_TYPE || $tmpl->{$key}->{strict_type} ) {
                $wrong++ unless ref $args->{$key} eq 
                                ref $tmpl->{$key}->{default};
            }

            ### somehow it's the wrong type.. warn for this! ###
            if( $wrong ) {
                _store_error(
                    loc(qq[Key '%1' is of invalid type for %2 provided by %3],
                        $key, _who_was_it(), _who_was_it(1)),
                    $verbose
                );     
                ++$flag && next;

            } else {

                ### if we got here, it's apparently an ok value for $key,
                ### so we'll set it in the default to return it in a bit
                
                $defs->{$key} = $args->{$key};
            }
        }
    }

    ### check if we need to store ###
    for my $key ( keys %$defs ) {
        if( my $scalar = $tmpl->{$key}->{store} ) {
            $$scalar = $defs->{$key};
            delete $defs->{$key} if $NO_DUPLICATES;
        }
    }              

    return $flag ? undef : $defs;
}

sub allow {
    my $val                 = shift;
    my $aref                = shift;

    my $wrong;
    if ( ref $aref eq 'Regexp' ) {
        $wrong++ unless defined $val and $val =~ /$aref/;

    } elsif ( ref $aref eq 'ARRAY' ) {
        #$wrong++ unless grep { ref $_ eq 'Regexp'
        #                            ? $val =~ /$_/
        #                            : _safe_eq($val, $_)
        #                     } @$aref;
        $wrong++ unless grep { allow( $val, $_ ) } @$aref;

    } elsif ( ref $aref eq 'CODE' ) {
        $wrong++ unless $aref->( $val );

    ### fall back to a simple 'eq'
    } else {
        $wrong++ unless _safe_eq( $val, $aref );
    }
    return !$wrong;
}    

### Like check_array, but tmpl is an array and arguments can be given
### in a positional way; the tmpl order is the argument order.
sub check_positional {
    my $atmpl   = shift;
    my $aref    = shift;
    my $verbose = shift || $VERBOSE || 0;

    ### reset the error string ###
    _clear_error();

    my %args;
    {
        local $STRIP_LEADING_DASHES = 1;
        my ($tmpl, $pos, $syn) = _atmpl_to_tmpl_pos_syn($atmpl);
        
        if ($#$aref == 1 && ref($aref->[0]) eq 'HASH') {