Declare::Constraints::Simple::Library::Base - Library Base Class

  package My::Constraint::Library;
  use warnings;
  use strict;

  # this installs the base class and helper functions
  use Declare::Constraints::Simple-Library;

  # we can also automagically provide other libraries
  # to the importer
  use base 'Declare::Constraints::Simple::Library::Numericals';

  # with this we define a constraint to check a value
  # against a serial number regular expression
  constraint 'SomeSerial',
    sub {
      return sub {
        return _true if $_[0] =~ /\d{3}-\d{3}-\d{4}/;
        return _false('Not in SomeSerial format');
      };
    };

  1;

  constraint 'Foo', sub { ... };

package Declare::Constraints::Simple::Library::Base;
use warnings;
use strict;

use aliased 'Declare::Constraints::Simple::Result';

use Carp::Clan qw(^Declare::Constraints::Simple);

our $FAIL_MESSAGE_DEFAULT = 'Validation Error';
our $FAIL_MESSAGE = '';
our $FAIL_INFO;
our %SCOPES;

use base 'Declare::Constraints::Simple::Library::Exportable';

sub install_into {
    my ($class, $target) = @_;

    {   no strict 'refs';
        unshift @{$target . '::ISA'}, $class;

        *{$target . '::' . $_} = $class->can($_)
            for qw/ 
                    constraint
                    _apply_checks
                    _listify
                    _result
                    _false
                    _true
                    _info
                    _with_message
                    _with_scope
                    _set_result
                    _get_result
                    _has_result
                /;
    }

    1;
}

sub fetch_constraint_declarations {
    my ($class) = @_;
    
    {   no strict 'refs';
        no warnings;
        return keys %{$class . '::CONSTRAINT_GENERATORS'};
    }
}

sub fetch_constraint_generator {
    my ($class, $name) = @_;

    my $generator = do {
        no strict 'refs';
        ${$class . '::CONSTRAINT_GENERATORS'}{$name};
    };
    croak "Unknown Constraint Generators: $name"
        unless $generator;

    return $class->prepare_generator($name, $generator);
}

sub prepare_generator {
    my ($class, $constraint, $generator) = @_;
    return sub {
        my (@g_args) = @_;
        my $closure = $generator->(@g_args);

        return sub {
            my (@c_args) = @_;

            local $FAIL_INFO;
            my $result = $closure->(@c_args);
            my $info = '';
            if ($FAIL_INFO) {
                $info = $FAIL_INFO;
                $info =~ s/([\[\]])/\\$1/gsm;
                $info = "[$info]";
            }
            $result->add_to_stack($constraint . $info) unless $result;

            return $result;
        };
    };
}

sub add_constraint_generator {
    my ($class, $name, $code) = @_;

    {   no strict 'refs';
        ${$class . '::CONSTRAINT_GENERATORS'}{$name} = $code;
    }

    1;
}

sub constraint {
    my ($name, $code) = @_;
    my $target = scalar(caller);
    $target->add_constraint_generator($name => $code);

    1;
}

sub _result {
    my ($result, $msg) = @_;
    my $result_obj = Result->new;
    $result_obj->set_valid($result);
    $result_obj->set_message(
        $FAIL_MESSAGE || $msg || $FAIL_MESSAGE_DEFAULT)
        unless $result_obj->is_valid;
    return $result_obj;
}

sub _false { _result(0, @_) }
sub _true  { _result(1, @_) }

sub _info  { $FAIL_INFO = shift }

sub _apply_checks {
    my ($value, $checks, $info) = @_;
    $checks ||= [];
    $FAIL_INFO = $info if $info;
    for (@$checks) {
        my $result = $_->($value);
        return $result unless $result->is_valid;
    }
    return _true;
}

sub _listify {
    my ($value) = @_;
    return (ref($value) eq 'ARRAY' ? $value : [$value]);
}

sub _with_message {
    my ($msg, $closure, @args) = @_;
    local $FAIL_MESSAGE = $msg;
    return $closure->(@args);
}

sub _with_scope {
    my ($scope_name, $closure, @args) = @_;
    local %SCOPES = ($scope_name => {})
        unless exists $SCOPES{$scope_name};
    return $closure->(@args);
}

sub _set_result {
    my ($scope, $name, $result) = @_;
    $SCOPES{$scope}{result}{$name} = $result;
    1;
}

sub _get_result {
    my ($scope, $name) = @_;
    return $SCOPES{$scope}{result}{$name};
}

sub _has_result {
    my ($scope, $name) = @_;
    return exists $SCOPES{$scope}{result}{$name};
}

1;