File Coverage

lib/CGI/ValidOp/Check.pm

Criterion	Covered	Total	%
statement	48	48	100.0
branch	16	16	100.0
condition	8	8	100.0
subroutine	13	13	100.0
pod	3	8	37.5
total	88	93	94.6

package CGI::ValidOp::Check;
use strict;
use warnings;

use base qw/ CGI::ValidOp::Base /;
use Carp;

my @ALLOWED_TYPES = ( qw/ regexp code /); # types of reference we allow for checks

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub PROPERTIES {
    {
        validator   => undef,
        errmsg      => undef,
        name        => undef,
        params      => undef,
        allow_tainted => 0,
    }
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# params are optional parameters passed in, e.g. "check_name(3,4)"
sub init {
    my $self = shift;
    my( $check_name, @params ) = @_;

    $check_name ||= 'default';
    my $pkg = ref $self;
    croak qq/No such check ("$check_name") in package "$pkg"./
        unless $self->can( $check_name );
    my( $validator, $errmsg ) = $self->$check_name;
    my $validator_type = ref $validator;
    croak join ' ', "Disallowed reference type for validator. You used $validator_type; valid types are:", @ALLOWED_TYPES
        unless $validator_type and grep /^$validator_type$/i, @ALLOWED_TYPES;

    $self->SUPER::init({
        validator   => $validator,
        errmsg      => $errmsg,
        name        => $check_name,
        params      => \@params,
    });
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# called by a check to indicate success: "pass( $value )"
sub pass {
    my $self = shift;
    my( $value ) = @_;
    ( $value, undef );
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# called by a check to indicate failure "fail( $errmsg )"
sub fail {
    my $self = shift;
    my( $errmsg ) = @_;
    ( undef, $errmsg );
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# check to see what type of validator we have and call the appropriate sub
sub check {
    my $self = shift;
    my( $tainted ) = @_;

    # trim whitespace
    if (defined $tainted) {
        $tainted =~ s/^\s+//;
        $tainted =~ s/\s+$//;
    }

    my $check_sub = 'check_'. lc ref $self->validator;
    $self->$check_sub( $tainted, $self->validator );
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# this method makes the decision about whether the test passed or failed
# if it gets undef it returns it with no error message
# if the regex then returns undef it returns an error
sub check_regexp {
    my $self = shift;
    my( $tainted, $validator ) = @_;
    return( undef, undef ) unless defined $tainted;
    $tainted =~ /($validator)/;
    return $1 unless wantarray;
    defined $1
        ? ( $1, undef )
        : ( undef, $self->errmsg );
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# this method expects the coderef to call either pass or fail
sub check_code {
    my $self = shift;
    my( $tainted, $validator ) = @_;
    my( $value, $errmsg ) = &$validator( $tainted, $self->params );
    croak 'Validator returned a tainted value'
        if $self->is_tainted( $value )
        and ! $self->allow_tainted;
    wantarray
        ? ( $value, $errmsg )
        : $value;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub default {
    (
        sub {
            croak 'You must override CGI::ValidOp::Check::check() with your own code.';
        },
        'Parameter $label contained invalid data.',
    )
}

1;

__END__