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

    use Params::Check::Faster 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::Faster::last_error();

    use Params::Check::Faster 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::Faster::WARNINGS_FATAL = 1;
        local $Params::Check::Faster::CALLER_DEPTH = $Params::Check::Faster::CALLER_DEPTH + 1;
        my $args_out = Params::Check::Faster::check($template, $args_in);

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

        return $args_out;
    }

package Params::Check::Faster;

use 5.006; #warnings.pm 
use strict;

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

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.03';
    $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 {
    # for speed purpose we don't copy @_; check if we have anything to work on
    if (!$_[0] || !$_[1]) {
        return;
    }

    my %template = %{$_[0]};
    my %args = %{$_[1]};
    my $verbose = $_[2] || $VERBOSE || 0;

    # clear current error
    _clear_error();

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

    # flag to see if anything went wrong
    my $wrong; 

    # key to remove from the args, if unauthorised
    my @keys_to_remove = ();

    # keys to rename : [ old_key_name, new_key_name]
    my @keys_to_rename = ();

    # list of values to store into ref : [ $type, $ref, $value ]
    my @to_store = ();

    # list of keys to delete from args
    my @to_delete = ();

#  ARG_LOOP:
    # loop on the arguments
    while (my ($arg_key, $arg_value) = each %args) {

        # handle key name
        if (!$PRESERVE_CASE || $STRIP_LEADING_DASHES) {
            my $orig_arg_key = $arg_key;
            $arg_key = lc($arg_key) unless $PRESERVE_CASE;
            $arg_key =~ s/^-// if $STRIP_LEADING_DASHES;
            if ($arg_key ne $orig_arg_key) {
                push @keys_to_rename, [ $arg_key, $orig_arg_key ];
            }
        }

        # the argument doesn't exist in the template
        if ( !exists $template{$arg_key} ) {
            if (!$ALLOW_UNKNOWN) {
                _store_error(
                             loc(q(Key '%1' is not a valid key for %2 provided by %3),
                                 $arg_key, _who_was_it(), _who_was_it(1)), $verbose);
                $warned = 1;
                push @keys_to_remove, $arg_key;
            }
            next;
        };

        # copy of this keys template instructions, to save derefs
        my %arg_template = %{delete $template{$arg_key} };

        if ($SANITY_CHECK_TEMPLATE) {
            foreach(grep { ! $known_keys{$_} } keys %arg_template) {
                _store_error(loc(q(Template type '%1' not supported [at key '%2']),
                                 $_, $arg_key), $verbose)
            }
        }

        # the argument cannot be overridden
        if ($arg_template{no_override}) {
            _store_error(
                loc(q(You are not allowed to override key '%1' for %2 from %3),
                    $arg_key, _who_was_it(), _who_was_it(1)),
                $verbose
            );
            $warned = 1;
            push @keys_to_remove, $arg_key;
            $template{$arg_key} = \%arg_template;
            next;
        }

        # check if you were supposed to provide defined() values
        if ( ($arg_template{defined} || $ONLY_ALLOW_DEFINED) && !defined $arg_value ) {
            _store_error(loc(q(Key '%1' must be defined when passed), $arg_key),
                         $verbose );
            $wrong = 1;
            push @keys_to_remove, $arg_key;
            $template{$arg_key} = \%arg_template;
            next;
        }

        # check if they should be of a strict type, and if it is
        if ( ($arg_template{strict_type} || $STRICT_TYPE) && ref $arg_value ne ref $arg_template{default}) {
            _store_error(loc(q(Key '%1' needs to be of type '%2'),
                             $arg_key, ref($arg_template{default}) || 'SCALAR'),
                         $verbose );
            $wrong = 1;
            push @keys_to_remove, $arg_key;
            $template{$arg_key} = \%arg_template;
            next;
        }

        # check if we have an allow handler, to validate against
        # allow() will report its own errors
        if (exists $arg_template{allow} && !do {
            local $_ERROR_STRING;
            allow($arg_value, $arg_template{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' provided by %4),
                        $arg_key, $arg_value, _who_was_it(),
                        _who_was_it(1)), $verbose);
            $wrong = 1;
            push @keys_to_remove, $arg_key;
            $template{$arg_key} = \%arg_template;
            next;
        }

        # check if we need to store the argument value to a provided ref
        if (my $ref = $arg_template{store}) {
            if ( !_store_var($arg_key, $ref, $arg_value, $verbose, \@to_store, \@to_delete)) {
                $wrong = 1;
                next;
            }
        }
    }


    # if we needed to rename keys
    foreach (@keys_to_rename) {
        $args{$_->[0]} = delete $args{$_->[1]};
    }

    # if we needed to remove unknown keys, so that default applies
    if (@keys_to_remove) {
        delete @args{@keys_to_remove};
    }

    # now check if there is any key left in the template
    while (my ($t_key, $t_value) = each %template) {

        # check if required key is missing
        if ($t_value->{required}) {
            _store_error(
                loc(q(Required option '%1' is not provided for %2 by %3),
                    $t_key, _who_was_it(), _who_was_it(1)), $verbose );
            $wrong = 1;
            next;
        }

        # set default argument omitted
        if (exists $t_value->{default}) {
            $args{$t_key} = $t_value->{default};
            # check if we need to store the default value to a provided ref
            if (my $ref = $t_value->{store}) {
                if (!_store_var($t_key, $ref, $t_value->{default}, $verbose, \@to_store, \@to_delete)) {
                    $wrong = 1;
                    next;
                }
            }
        }
        # special case to be backward compatible
        if ($SANITY_CHECK_TEMPLATE && exists $t_value->{store} && !ref $t_value->{store} ) {
            _store_error( loc(
                              q(Store variable for '%1' is not a reference!), $t_key
                             ), $verbose);
        }

    }

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

    # if $wrong is set, somethign 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

    foreach(@to_store) {
        my ($type, $ref, $value) = @$_;
        if ($type == 0) {
            $$ref = $value;
        }
        elsif ($type == 1) {
            @{$ref} = @{$value};
        }
        elsif ($type == 2) {
            %{$ref} = %{$value};
        }
    }
    $NO_DUPLICATES and delete @args{@to_delete};

    # now, everything is fine, we can return the arguments
    return(\%args);
}

sub _store_var {
    my ($key, $ref, $value, $verbose, $to_store, $to_delete) = @_;

    if ($SANITY_CHECK_TEMPLATE && !ref($ref)) {
        _store_error( loc(
                          q(Store variable for '%1' is not a reference!), $key
                         ), $verbose, 1 );
        return; #error
    }
    
    if (ref($ref) eq 'ARRAY') {
        if (ref($value) ne 'ARRAY') {
            _store_error(
                loc(q(Key '%1' (value %2) is not a ARRAYREF. For %3 by %4),
                    $key, $value, _who_was_it(1), _who_was_it(2)), $verbose, 1);
            return; # error
    }
        # push the refs/values to execute later
        push @$to_store, [ 1, $ref, $value]; # 1 = array
        $NO_DUPLICATES and push @$to_delete, $key;
    }
    elsif (ref($ref) eq 'HASH') {
    if (ref($value) ne 'HASH') {
            _store_error(
                loc(q(Key '%1' (value %2) is not a HASHREF. For %3 by %4),
                    $key, $value, _who_was_it(1), _who_was_it(2)), $verbose, 1);
            return; # error
    }
        # push the refs/values to execute later
        push @$to_store, [ 2, $ref, $value]; # 2 = hash
        $NO_DUPLICATES and push @$to_delete, $key;
    }
    else {
        # push the refs/values to execute later
        push @$to_store, [ 0, $ref, $value]; # 0 = scalar ref
        $NO_DUPLICATES and push(@$to_delete, $key);
    }

    return 1; # success
}

sub allow {

    # it's a regexp
    if (ref($_[1]) eq 'Regexp') {
        no warnings;
        return(scalar $_[0] =~ /$_[1]/); ## no critic (Regular expression)
    }

    # it's a sub
    if (ref($_[1]) eq 'CODE') {
        return $_[1]->($_[0]);
    }
    
    # it's an array
    if (ref($_[1])eq 'ARRAY') {

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

    # fall back to a simple, but safe 'eq'
    return (defined $_[0] && defined $_[1]
            ? $_[0] eq $_[1]
            : defined $_[0] eq defined $_[1]
           );
}

# helper functions

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: