Params::Check - A generic input parsing/checking mechanism.

    use Params::Check qw[check allow last_error];

    sub fill_personal_info {
        my %hash = @_;
        my $x;

        my $tmpl = {
            firstname   => { required   => 1, defined => 1 },
            lastname    => { required   => 1, store => \$x },
            gender      => { required   => 1,
                             allow      => [qr/M/i, qr/F/i],
                           },
            married     => { allow      => [0,1] },
            age         => { default    => 21,
                             allow      => qr/^\d+$/,
                           },

            phone       => { allow => [ sub { return 1 if /$valid_re/ },
                                        '1-800-PERL' ]
                           },
            id_list     => { default        => [],
                             strict_type    => 1
                           },
            employer    => { default => 'NSA', no_override => 1 },
        };

        ### check() returns a hashref of parsed args on success ###
        my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
                            or die qw[Could not parse arguments!];

        ... other code here ...
    }

    my $ok = allow( $colour, [qw|blue green yellow|] );

    my $error = Params::Check::last_error();

    use Params::Check qw[check];

    my $parsed = check( \%template, \%arguments, $VERBOSE )
                    or warn q[Arguments could not be parsed!];

    function( -key => 'val' );

    sub check {
        my ($template, $args_in) = @_;

        local $Params::Check::WARNINGS_FATAL = 1;
        local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
        my $args_out = Params::Check::check($template, $args_in);

        my_stacktrace(Params::Check::last_error) unless $args_out;

        return $args_out;
    }

package Params::Check;

use strict;

use Carp                        qw[carp croak];
use Locale::Maketext::Simple    Style => 'gettext';

use Data::Dumper;

BEGIN {
    use Exporter    ();
    use vars        qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
                        $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
                        $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
                        $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
                    ];

    @ISA        =   qw[ Exporter ];
    @EXPORT_OK  =   qw[check allow last_error];

    $VERSION                = '0.28';
    $VERBOSE                = $^W ? 1 : 0;
    $NO_DUPLICATES          = 0;
    $STRIP_LEADING_DASHES   = 0;
    $STRICT_TYPE            = 0;
    $ALLOW_UNKNOWN          = 0;
    $PRESERVE_CASE          = 0;
    $ONLY_ALLOW_DEFINED     = 0;
    $SANITY_CHECK_TEMPLATE  = 1;
    $WARNINGS_FATAL         = 0;
    $CALLER_DEPTH           = 0;
}

my %known_keys = map { $_ => 1 }
                    qw| required allow default strict_type no_override
                        store defined |;

sub check {
    my ($utmpl, $href, $verbose) = @_;

    ### did we get the arguments we need? ###
    return if !$utmpl or !$href;

    ### sensible defaults ###
    $verbose ||= $VERBOSE || 0;

    ### clear the current error string ###
    _clear_error();

    ### XXX what type of template is it? ###
    ### { key => { } } ?
    #if (ref $args eq 'HASH') {
    #    1;
    #}

    ### clean up the template ###
    my $args = _clean_up_args( $href ) or return;

    ### sanity check + defaults + required keys set? ###
    my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
                    or return;

    ### deref only once ###
    my %utmpl   = %$utmpl;
    my %args    = %$args;
    my %defs    = %$defs;

    ### flag to see if anything went wrong ###
    my $wrong; 
    
    ### flag to see if we warned for anything, needed for warnings_fatal
    my $warned;

    for my $key (keys %args) {

        ### you gave us this key, but it's not in the template ###
        unless( $utmpl{$key} ) {

            ### but we'll allow it anyway ###
            if( $ALLOW_UNKNOWN ) {
                $defs{$key} = $args{$key};

            ### warn about the error ###
            } 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);
                $warned ||= 1;
            }
            next;
        }

        ### check if you're even allowed to override this key ###
        if( $utmpl{$key}->{'no_override'} ) {
            _store_error(
                loc(q[You are not allowed to override key '%1'].
                    q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
                $verbose
            );
            $warned ||= 1;
            next;
        }

        ### copy of this keys template instructions, to save derefs ###
        my %tmpl = %{$utmpl{$key}};

        ### check if you were supposed to provide defined() values ###
        if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and
            not defined $args{$key}
        ) {
            _store_error(loc(q|Key '%1' must be defined when passed|, $key),
                $verbose );
            $wrong ||= 1;
            next;
        }

        ### check if they should be of a strict type, and if it is ###
        if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
            (ref $args{$key} ne ref $tmpl{'default'})
        ) {
            _store_error(loc(q|Key '%1' needs to be of type '%2'|,
                        $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
            $wrong ||= 1;
            next;
        }

        ### check if we have an allow handler, to validate against ###
        ### allow() will report its own errors ###
        if( exists $tmpl{'allow'} and not do {
                local $_ERROR_STRING;
                allow( $args{$key}, $tmpl{'allow'} )
            }         
        ) {
            ### stringify the value in the error report -- we don't want dumps
            ### of objects, but we do want to see *roughly* what we passed
            _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
                             q|provided by %4|,
                            $key, "$args{$key}", _who_was_it(),
                            _who_was_it(1)), $verbose);
            $wrong ||= 1;
            next;
        }

        ### we got here, then all must be OK ###
        $defs{$key} = $args{$key};

    }

    ### croak with the collected errors if there were errors and 
    ### we have the fatal flag toggled.
    croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;

    ### done with our loop... if $wrong is set, something went wrong
    ### and the user is already informed, just return...
    return if $wrong;

    ### check if we need to store any of the keys ###
    ### can't do it before, because something may go wrong later,
    ### leaving the user with a few set variables
    for my $key (keys %defs) {
        if( my $ref = $utmpl{$key}->{'store'} ) {
            $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
        }
    }

    return \%defs;
}

sub allow {
    ### use $_[0] and $_[1] since this is hot code... ###
    #my ($val, $ref) = @_;

    ### it's a regexp ###
    if( ref $_[1] eq 'Regexp' ) {
        local $^W;  # silence warnings if $val is undef #
        return if $_[0] !~ /$_[1]/;

    ### it's a sub ###
    } elsif ( ref $_[1] eq 'CODE' ) {
        return unless $_[1]->( $_[0] );

    ### it's an array ###
    } elsif ( ref $_[1] eq 'ARRAY' ) {

        ### loop over the elements, see if one of them says the
        ### value is OK
        ### also, short-circuit when possible
        for ( @{$_[1]} ) {
            return 1 if allow( $_[0], $_ );
        }
        
        return;

    ### fall back to a simple, but safe 'eq' ###
    } else {
        return unless _safe_eq( $_[0], $_[1] );
    }

    ### we got here, no failures ###
    return 1;
}

### helper functions ###

### clean up the template ###
sub _clean_up_args {
    ### don't even bother to loop, if there's nothing to clean up ###
    return $_[0] if $PRESERVE_CASE and !$STRIP_LEADING_DASHES;

    my %args = %{$_[0]};

    ### keys are note aliased ###
    for my $key (keys %args) {
        my $org = $key;
        $key = lc $key unless $PRESERVE_CASE;
        $key =~ s/^-// if $STRIP_LEADING_DASHES;
        $args{$key} = delete $args{$org} if $key ne $org;
    }

    ### return references so we always return 'true', even on empty
    ### arguments
    return \%args;
}

sub _sanity_check_and_defaults {
    my %utmpl   = %{$_[0]};
    my %args    = %{$_[1]};
    my $verbose = $_[2];

    my %defs; my $fail;
    for my $key (keys %utmpl) {

        ### check if required keys are provided
        ### keys are now lower cased, unless preserve case was enabled
        ### at which point, the utmpl keys must match, but that's the users
        ### problem.
        if( $utmpl{$key}->{'required'} and not exists $args{$key} ) {
            _store_error(
                loc(q|Required option '%1' is not provided for %2 by %3|,
                    $key, _who_was_it(1), _who_was_it(2)), $verbose );

            ### mark the error ###
            $fail++;
            next;
        }

        ### next, set the default, make sure the key exists in %defs ###
        $defs{$key} = $utmpl{$key}->{'default'}
                        if exists $utmpl{$key}->{'default'};

        if( $SANITY_CHECK_TEMPLATE ) {
            ### last, check if they provided any weird template keys
            ### -- do this last so we don't always execute this code.
            ### just a small optimization.
            map {   _store_error(
                        loc(q|Template type '%1' not supported [at key '%2']|,
                        $_, $key), 1, 1 );
            } grep {
                not $known_keys{$_}
            } keys %{$utmpl{$key}};
        
            ### make sure you passed a ref, otherwise, complain about it!
            if ( exists $utmpl{$key}->{'store'} ) {
                _store_error( loc(
                    q|Store variable for '%1' is not a reference!|, $key
                ), 1, 1 ) unless ref $utmpl{$key}->{'store'};
            }
        }
    }

    ### errors found ###
    return if $fail;

    ### return references so we always return 'true', even on empty
    ### defaults
    return \%defs;
}

sub _safe_eq {
    ### only do a straight 'eq' if they're both defined ###
    return defined($_[0]) && defined($_[1])
                ? $_[0] eq $_[1]
                : defined($_[0]) eq defined($_[1]);
}

sub _who_was_it {
    my $level = $_[0] || 0;

    return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
}

{   $_ERROR_STRING = '';

    sub _store_error {
        my($err, $verbose, $offset) = @_[0..2];
        $verbose ||= 0;
        $offset  ||= 0;
        my $level   = 1 + $offset;

        local $Carp::CarpLevel = $level;

        carp $err if $verbose;

        $_ERROR_STRING .= $err . "\n";
    }

    sub _clear_error {
        $_ERROR_STRING = '';
    }

    sub last_error { $_ERROR_STRING }
}

1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4: