File Coverage

blib/lib/Validation/Class.pm

Criterion	Covered	Total	%
statement	184	204	90.2
branch	38	72	52.7
condition	33	68	48.5
subroutine	53	61	86.8
pod	15	32	46.8
total	323	437	73.9

# ABSTRACT: Powerful Data Validation Framework

package Validation::Class;

use 5.10.0;
use strict;
use warnings;

use Module::Find;

use Validation::Class::Util '!has';
use Clone 'clone';
use Exporter ();

use Validation::Class::Prototype;

our $VERSION = '7.900059'; # VERSION

our @ISA    = qw(Exporter);
our @EXPORT = qw(

    adopt
    adt
    attribute
    bld
    build
    dir
    directive
    doc
    document
    ens
    ensure
    fld
    field
    flt
    filter
    has
    load
    msg
    message
    mth
    method
    mxn
    mixin
    pro
    profile
    set

);

sub return_class_proto {

    my $class = shift || caller(2);

    return prototype_registry->get($class) || do {

        # build new prototype class

        my $proto = Validation::Class::Prototype->new(
            package => $class
        );

        no strict 'refs';
        no warnings 'redefine';

        # respect foreign constructors (such as $class->new) if found

        my $new = $class->can("new") ?
            "initialize_validator" : "new"
        ;

        # injected into every derived class (override if necessary)

        *{"$class\::$new"}      = sub { goto \&$new };
        *{"$class\::proto"}     = sub { goto \&prototype };
        *{"$class\::prototype"} = sub { goto \&prototype };

        # inject prototype class aliases unless exist

        my @aliases = $proto->proxy_methods;

        foreach my $alias (@aliases) {

            next if $class->can($alias);

            # slight-of-hand

            $proto->set_method($alias, sub {

                shift @_;

                $proto->$alias(@_);

            });

        }

        # inject wrapped prototype class aliases unless exist

        my @wrapped_aliases = $proto->proxy_methods_wrapped;

        foreach my $alias (@wrapped_aliases) {

            next if $class->can($alias);

            # slight-of-hand

            $proto->set_method($alias, sub {

                my $self = shift @_;

                $proto->$alias($self, @_);

            });

        }

        # cache prototype
        prototype_registry->add($class => $proto);

        $proto; # return-once

    };

}

sub configure_class_proto {

    my $configuration_routine = pop;

    return unless "CODE" eq ref $configuration_routine;

    no strict 'refs';

    my $proto = return_class_proto shift;

    $configuration_routine->($proto);

    return $proto;

}

sub import {

    my $caller = caller(0) || caller(1);

    strict->import;
    warnings->import;

    __PACKAGE__->export_to_level(1, @_);

    return return_class_proto $caller # provision prototype when used

}

sub initialize_validator {

    my $self   = shift;
    my $proto  = $self->prototype;

    my $arguments = $proto->build_args(@_);

    # provision a validation class configuration

    $proto->snapshot;

    # override prototype attributes if requested

    if (defined($arguments->{fields})) {
        my $fields = delete $arguments->{fields};
        $proto->fields->clear->add($fields);
    }

    if (defined($arguments->{params})) {
        my $params = delete $arguments->{params};
        $proto->params->clear->add(clone $params);
    }

    # process attribute assignments

    my $proxy_methods = { map { $_ => 1 } ($proto->proxy_methods) } ;

    while (my($name, $value) = each (%{$arguments})) {

        $self->$name($value) if

            $self->can($name)              &&
            $proto->fields->has($name)     ||
            $proto->attributes->has($name) || $proxy_methods->{$name}

        ;

    }

    # process builders

    foreach my $builder ($proto->builders->list) {

        $builder->($self, $arguments);

    }

    # initialize prototype

    $proto->normalize($self);

    # ready-set-go !!!

    return $self;

}




sub adt { goto &adopt } sub adopt {

    my $package = shift if @_ == 4;

    my ($class, $type, $name) = @_;

    my $aliases = {
        has => 'attribute',
        dir => 'directive',
        doc => 'document',
        fld => 'field',
        flt => 'filter',
        msg => 'message',
        mth => 'method',
        mxn => 'mixin',
        pro => 'profile'
    };

    my $keywords = { map { $_ => $_ } values %{$aliases} };

    $type = $keywords->{$type} || $aliases->{$type};

    return unless $class && $name && $type;

    my $store  = "${type}s";
    my $config = prototype_registry->get($class)->configuration;
    my $data   = clone $config->$store->get($name);

    @_ = ($name => $data) and goto &$type;

    return;

}


sub has { goto &attribute } sub attribute {

    my $package = shift if @_ == 3;

    my ($attributes, $default) = @_;

    return unless $attributes;

    $attributes = [$attributes] unless isa_arrayref $attributes;

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_attribute($_ => $default) for @{$attributes};

        return $proto;

    };

}


sub bld { goto &build } sub build {

    my $package = shift if @_ == 2;

    my ($code) = @_;

    return unless ("CODE" eq ref $code);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_builder($code);

        return $proto;

    };

}


sub dir { goto &directive } sub directive {

    my $package = shift if @_ == 3;

    my ($name, $code) = @_;

    return unless ($name && $code);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_directive($name, $code);

        return $proto;

    };

}


sub doc { goto &document } sub document {

    my $package = shift if @_ == 3;

    my ($name, $data) = @_;

    $data ||= {};

    return unless ($name && $data);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_document($name, $data);

        return $proto;

    };

};



sub ens { goto &ensure } sub ensure {

    my $package = shift if @_ == 3;

    my ($name, $data) = @_;

    $data ||= {};

    return unless ($name && $data);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_ensure($name, $data);

        return $proto;

    };

}


sub fld { goto &field } sub field {

    my $package = shift if @_ == 3;

    my ($name, $data) = @_;

    $data ||= {};

    return unless ($name && $data);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_field($name, $data);

        return $proto;

    };

}


sub flt { goto &filter } sub filter {

    my $package = shift if @_ == 3;

    my ($name, $code) = @_;

    return unless ($name && $code);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_filter($name, $code);

        return $proto;

    };

}


sub set { goto &load } sub load {

    my $package;
    my $data;

    # handle different types of invocations

    # 1   - load({})
    # 2+  - load(a => b)
    # 2+  - package->load({})
    # 3+  - package->load(a => b)

    # --

    # load({})

    if (@_ == 1) {

        if ("HASH" eq ref $_[0]) {

            $data = shift;

        }

    }

    # load(a => b)
    # package->load({})

    elsif (@_ == 2) {

        if ("HASH" eq ref $_[-1]) {

            $package = shift;
            $data    = shift;

        }

        else {

            $data = {@_};

        }

    }

    # load(a => b)
    # package->load(a => b)

    elsif (@_ >= 3) {

        if (@_ % 2) {

            $package = shift;
            $data    = {@_};

        }

        else {

            $data = {@_};

        }

    }

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_settings($data);

        return $proto;

    };

}


sub msg { goto &message } sub message {

    my $package = shift if @_ == 3;

    my ($name, $template) = @_;

    return unless ($name && $template);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_message($name, $template);

        return $proto;

    };

}


sub mth { goto &method } sub method {

    my $package = shift if @_ == 3;

    my ($name, $data) = @_;

    return unless ($name && $data);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_method($name, $data);

        return $proto;

    };

}


sub mxn { goto &mixin } sub mixin {

    my $package = shift if @_ == 3;

    my ($name, $data) = @_;

    $data ||= {};

    return unless ($name && $data);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_mixin($name, $data);

        return $proto;

    };

}


sub new {

    my $class = shift;

    $class = ref $class || $class;

    my $proto = return_class_proto $class;

    my $self  = bless {},  $class;

    initialize_validator $self, @_;

    return $self;

}


sub pro { goto &profile } sub profile {

    my $package = shift if @_ == 3;

    my ($name, $code) = @_;

    return unless ($name && $code);

    return configure_class_proto $package => sub {

        my ($proto) = @_;

        $proto->register_profile($name, $code);

        return $proto;

    };

}


sub proto { goto &prototype } sub prototype {

    my ($self) = pop @_;

    return return_class_proto ref $self || $self;

}


1;

__END__