File Coverage

blib/lib/Data/Validator.pm

Criterion	Covered	Total	%
statement	140	142	98.5
branch	64	66	96.9
condition	6	8	75.0
subroutine	15	15	100.0
pod	4	9	44.4
total	229	240	95.4

package Data::Validator;
use 5.008_001;
use Mouse;
use Mouse::Util::TypeConstraints ();
use Mouse::Util                  ();
use Carp                         ();

our $VERSION = '1.07';

*_isa_tc  = \&Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint;
*_does_tc = \&Mouse::Util::TypeConstraints::find_or_create_does_type_constraint;

has rules => (
    is       => 'ro',
    isa      => 'ArrayRef',
    required => 1,
);

no Mouse;

my %rule_attrs = map { $_ => undef }qw(
    isa does coerce
    default optional
    xor
    documentation
);

sub BUILDARGS {
    my($class, @mapping) = @_;

    my %xor;

    my @rules;
    while(my($name, $rule_ref) = splice @mapping, 0, 2) {
        my %rule;
        if(!Mouse::Util::TypeConstraints::HashRef($rule_ref)) {
            %rule = (isa => $rule_ref);
        }
        else {
            %rule = %{$rule_ref}
        }

        # validate the rule
        my $used = 0;
        foreach my $attr(keys %rule_attrs) {
            exists($rule{$attr}) and $used++;
        }
        if($used < keys %rule) {
            my @unknowns = grep { not exists $rule_attrs{$_} }  sort keys %rule;
            Carp::croak("Wrong definition for '$name':"
                . ' Unknown attributes: '
                . Mouse::Util::quoted_english_list(@unknowns) );
        }

        # setup the rule
        if(defined $rule{xor}) {
            my @xors = Mouse::Util::TypeConstraints::ArrayRef($rule{xor})
                    ? @{$rule{xor}}
                    :  ($rule{xor});
            $xor{$name} = $rule{xor} = \@xors;
        }

        if(defined $rule{isa}) {
            $rule{type} = _isa_tc(delete $rule{isa});
        }
        if(defined $rule{does}) {
            defined($rule{type})
                and Carp::croak("Wrong definition for '$name':"
                    . q{ You cannot use 'isa' and 'does' together});
            $rule{type} = _does_tc(delete $rule{does});
        }

        if(defined $rule{type} && not defined $rule{coerce}) {
            $rule{coerce} = $rule{type}->has_coercion;
        }

        $rule{name} = $name;

        push @rules, \%rule;
    }

    # to check xor first and only once, move xor configuration into front rules
    if(%xor) {
        my %byname = map { $_->{name} => $_ } @rules;
        while(my($this, $others) = each %xor) {
            foreach my $other_name(@{$others}) {
                my $other_rule = $byname{$other_name}
                    || Carp::croak("Wrong definition for '$this':"
                        . " Unknown parameter name '$other_name'"
                        . " specified as exclusive-or");

                push @{$other_rule->{xor} ||= []}, $this;
            }
        }
    }

    return { rules => \@rules };
}

sub with {
    my($self, @roles) = @_;
    foreach my $role(@roles) {
        next if ref $role;
        $role = Mouse::Util::load_first_existing_class(
            __PACKAGE__ . '::Role::' . $role,
            $role,
        );
    }
    Mouse::Util::apply_all_roles($self, @roles);
    return $self;
}

sub find_rule {
    my($self, $name) = @_;
    foreach my $rule(@{$self->rules}) {
        return $rule if $rule->{name} eq $name;
    }
    return undef;
}

sub validate {
    my $self = shift;
    my $args = $self->initialize(@_);

    my %skip;
    my @errors;
    my @missing;
    my $nargs = scalar keys %{$args};
    my $used  = 0;
    my $rules = $self->rules;
    RULE: foreach my $rule(@{ $rules }) {
        my $name = $rule->{name};
        next RULE if exists $skip{$name};

        if(exists $args->{$name}) {

            if(exists $rule->{type}) {
                my $err = $self->apply_type_constraint($rule, $args, $name);
                if($err) {
                    push @errors, $self->make_error(
                        type    => 'InvalidValue',
                        message => $err,
                        name    => $name,
                    );
                    next RULE;
                }
            }

            if($rule->{xor}) {
                # checks conflicts with exclusive arguments
                foreach my $other_name( @{ $rule->{xor} } ) {
                    if(exists $args->{$other_name}) {
                        push @errors, $self->make_error(
                            type    => 'ExclusiveParameter',
                            message => "Exclusive parameters passed together:"
                                     . " '$name' v.s. '$other_name'",
                            name    => $name,
                            conflict=> $other_name,
                        );
                    }
                    $skip{$other_name}++;
                }
            }
            $used++;
        }
        elsif(exists $rule->{default}) {
            my $default = $rule->{default};
            $args->{$name} = Mouse::Util::TypeConstraints::CodeRef($default)
                ? $default->($self, $rule, $args)
                : $default;
        }
        elsif(!$rule->{optional}) {
            push @missing, $rule;
        }
    }


    if(@missing) {
        MISSING: foreach my $rule(@missing) {
            my $name = $rule->{name};
            next if exists $skip{$name};

            my @xors;
            if($rule->{xor}) {
                foreach my $other_name(@{$rule->{xor}}) {
                    next MISSING if exists $args->{$other_name};
                    push @xors, $other_name;
                }
            }
            my $real_missing = @xors
                ? sprintf(q{'%s' (or %s)},
                    $name, Mouse::Util::quoted_english_list(@xors) )
                : sprintf(q{'%s'}, $name);
            push @errors, $self->make_error(
                type    => 'MissingParameter',
                message => "Missing parameter: $real_missing",
                name    => $name,
            );
        }
    }


    if($used < $nargs) {
        my %unknowns = $self->unknown_parameters($rules, $args);
        if(keys %unknowns) {
            foreach my $name( sort keys %unknowns ) {
                push @errors, $self->make_error(
                    type    => 'UnknownParameter',
                    message => "Unknown parameter: '$name'",
                    name    => $name,
                );
            }
        }
    }

    # make it restricted
    &Internals::SvREADONLY($args, 1);

    if(@errors) {
        $args = $self->found_errors($args, @errors);
    }

    return $args;
}

__PACKAGE__->meta->add_method( initialize => \&Mouse::Object::BUILDARGS );

sub unknown_parameters {
    my($self, $rules, $args) = @_;
    my %knowns  = map { $_->{name} => undef } @{$rules};
    return map {
        !exists $knowns{$_}
            ? ($_ => delete $args->{$_})
            : ()
    } keys %{$args};
}

sub found_errors {
    my($self, $args, @errors) = @_;
    my $msg = '';
    foreach my $e(@errors) {
        $msg .= $e->{message} . "\n";
    }
    $self->throw_error($msg . '... found');
}

sub make_error {
    my($self, %e) = @_;
    return \%e;
}

sub throw_error {
    my($self, $message) = @_;
    local $Carp::CarpLevel = $Carp::CarpLevel + 2; # &throw_error + &validate
    confess($message);
}

sub apply_type_constraint {
    my($self, $rule, $args, $name) = @_;
    my $tc = $rule->{type};
    return '' if $tc->check($args->{$name});

    if($rule->{coerce}) {
        my $value = $tc->coerce($args->{$name});
        if($tc->check($value)) {
            $args->{$name} = $value; # commit
            return '';
        }
    }

    return "Invalid value for '$rule->{name}': "
        . $tc->get_message($args->{$name});
}

__PACKAGE__->meta->make_immutable;
__END__