File Coverage

blib/lib/Scalar/Validation.pm

Criterion	Covered	Total	%
statement	269	312	86.2
branch	88	110	80.0
condition	21	33	63.6
subroutine	67	78	85.9
pod	6	25	24.0
total	451	558	80.8

# perl
#
# Class Scalar::Validation
#
# Simple rule based validation package for scalar values
#
# Ralf Peine, Thu Sep  4 08:34:45 2014
#
# More documentation at the end of file
#------------------------------------------------------------------------------

$VERSION = "0.614";

package Scalar::Validation;

use base qw (Exporter);

use strict;
use warnings;

our @EXPORT = qw();
our @EXPORT_OK = qw (validate is_valid validate_and_correct npar named_parameter par parameter
                     get_rules rule_known declare_rule delete_rule replace_rule enum Enum enum_explained Enum_explained
                     greater_than greater_equal less_than less_equal equal_to g_t g_e l_t l_e
                     is_a
                     convert_to_named_params parameters_end p_end
                     validation_trouble validation_messages get_and_reset_validation_messages prepare_validation_mode);

our %EXPORT_TAGS = (
        all => [qw(validate is_valid validate_and_correct npar named_parameter par parameter
                   get_rules rule_known declare_rule delete_rule replace_rule enum Enum enum_explained Enum_explained
                   greater_than greater_equal less_than less_equal equal_to g_t g_e l_t l_e
                   is_a
                   convert_to_named_params parameters_end p_end
                   validation_trouble validation_messages get_and_reset_validation_messages prepare_validation_mode)],
);

use Carp;
# use Data::Dumper;

# ------------------------------------------------------------------------------
#
# Initiliazation
#
# ------------------------------------------------------------------------------

our $ignore_callers    = { __PACKAGE__ , 1 };

our $ignore_caller_pattern;

update_caller_pattern();

_init_run_API();

sub update_caller_pattern {
    $ignore_caller_pattern = eval ("qr/^(".join("|",keys (%$ignore_callers)).")/o");
}

sub ignore_caller {
    my $module_string = shift;

    die "not a module string: '$module_string'" unless $module_string || $module_string =~ /^[\w:]+$/;

    $ignore_callers->{$module_string} = 1;
    update_caller_pattern();
}

# ------------------------------------------------------------------------------
#
# default actions, not changable
#
# ------------------------------------------------------------------------------

my $croak_sub = sub { croak "Error: ",@_; };

my $get_caller_info_default = sub {
    my ($module, $file_name, $line, $sub_name);
    $sub_name     = __PACKAGE__;
    my $call_level = 1;

    while ($sub_name =~ $ignore_caller_pattern) {
        ($module, $file_name, $line, $sub_name) = caller($call_level++);
        $sub_name = '' unless $sub_name;
    }

    $sub_name = "MAIN" unless $sub_name;
    return $sub_name;
};

# ------------------------------------------------------------------------------
#
# variables my be overwritten by user
#
# ------------------------------------------------------------------------------

our $message_store     = undef; # local $Scalar::Validation::message_store = []; # to start storing messages
our $trouble_level     = 0;     # to count failed validations. Not affected by is_valid(...)
our $off               = 0;     # no validation checks if $off == 1
our $validate_defaults = 1;     # validate default values defined by -Default rule, if set

# ------------------------------------------------------------------------------
#
# actions, changable
#
# ------------------------------------------------------------------------------

our $fail_action     = $croak_sub;
our $get_caller_info = $get_caller_info_default;

# ------------------------------------------------------------------------------
#
#  private vars of Validation "Instance"
#
# ------------------------------------------------------------------------------
my $non_blessed = {
    REF   => 1,
    ARRAY => 1,
    HASH  => 1,
};

my $special_rules;
my $rule_store;
my $get_content_subs;


# ------------------------------------------------------------------------------
#
# normal rules, can be added, replaced, removed
#
# ------------------------------------------------------------------------------

$rule_store = {

    # --- This rules are needed for Validation.pm to work, don't delete or change! ---

    Defined     =>   { -name    => 'Defined',
                       -where   => sub { defined $_ },
                       -message => sub { "value is not defined" },
                       -owner   => 'CPAN',
                       -description => "Value is defined",
    },
    Filled      =>   { -name    => 'Filled',
                       -where   => sub { defined $_ and ref($_) eq '' and $_ ne '' },
                       -message => sub { "value is not set" },
                       -owner   => 'CPAN',
                       -description => "Value is Scalar and defined and not empty ('')",
    },
    Empty       =>   { -name    => 'Empty',
                       -where   => sub { !defined $_ or $_ eq '' },
                       -message => sub { "value $_ has to be empty" },
                       -owner   => 'CPAN',
                       -description => "Value is not defined or ''",
    },
    Optional    =>   { -name    => 'Optional',
                       -where   => sub { 1; },
                       -message => sub { "value is optional" },
                       -owner   => 'CPAN',
                       -description => "Value is optional, cannot fail. Use as last entry in -Or rule.",
    },
    String      =>   { -name    => 'String',
                       -where   => sub { defined $_ and ref($_) eq '' },
                       -message => sub { "value $_ is not a string" },
                       -owner   => 'CPAN',
                       -description => "Values is a Scalar and defined",
    },
    Int =>           { -name    => 'Int',
                       -as      => 'Filled',
                       -where   => sub { /^[\+\-]?\d+$/ },
                       -message => sub { "value $_ is not an integer" },
                       -owner   => 'CPAN',
                       -description => "Value is an integer",
    },
    Even =>          { -name    => 'Even',
                       -as      => 'Int',
                       -where   => sub { $_ % 2 ? 0: 1; },
                       -message => sub { "value $_ is not an integer or not even"},
                       -owner   => 'CPAN',
                       -description => 'Value is an even integer ($_ % 2 == 0)',
    },
    Scalar      =>   { -name    => 'Scalar',
                       -where   => sub { ref($_) eq '' },
                       -message => sub { "value $_ is not a scalar" },
                       -owner   => 'CPAN',
                       -description => 'Value is a Scalar : ref ($_) eq ""',
    },
    Ref         =>   { -name    => 'Ref',
                       -where   => sub { $_ and ref($_) ne '' },
                       -message => sub { "value $_ is not a reference" },
                       -owner   => 'CPAN',
                       -description => "Value is a reference and not a scalar.",
    },
    ArrayRef    =>   { -name    => 'ArrayRef',
                       -where   => sub { $_ and ref($_) eq 'ARRAY' },
                       -message => sub { "value $_ is not a array reference" },
                       -owner   => 'CPAN',
                       -description => "Value is an Array reference.",
    },
    HashRef     =>   { -name    => 'HashRef',
                       -where   => sub { $_ and ref($_) eq 'HASH' },
                       -message => sub { "value $_ is not a hash reference" },
                       -owner   => 'CPAN',
                       -description => "Value is a Hash reference.",
    },
    CodeRef     =>   { -name    => 'CodeRef',
                       -where   => sub { $_ and ref($_) eq 'CODE' },
                       -message => sub { "value $_ is not a code reference" },
                       -owner   => 'CPAN',
                       -description => "Value is a Code reference.",
    },
    Class       =>   { -name    => 'Class',
                       -where   => sub { return 0 unless $_;
                                         my $type_name = ref($_);
                                         !$type_name || $non_blessed->{$type_name} ? 0: 1;
                       },
                       -message => sub { "value $_ is not a reference" },
                       -owner   => 'CPAN',
                       -description => "Value is a reference and not a scalar.",
    },

    # --- Some additional global rules --------------------

    ExistingFile  => { -name    => 'ExistingFile',
                       -as      => 'Filled',
                       -where   => sub { -f $_ },
                       -message => sub { "$_ is not a valid name of an existing file"},
                       -owner   => 'CPAN',
                       -description => "File with given file name has to exist"
    },

    Bool =>          { -name    => 'Bool',
                       -where   => sub { ref ($_) ? 0: 1 },
                       -message => sub { "value $_ is not a bool value" },
                       -owner   => 'CPAN',
                       -description => "Value is a Scalar, all values including undef allowed",
    },
    PositiveInt =>   { -name    => 'PositiveInt',
                       -as      => 'Int',
                       -where   => sub { $_ >= 0 },
                       -message => sub { "value $_ is not a positive integer" },
                       -owner   => 'CPAN',
                       -description => "Value is a positive integer",
    },
    NegativeInt =>   { -name    => 'NegativeInt',
                       -as      => 'Int',
                       -where   => sub { $_ < 0 },
                       -message => sub { "value $_ is not a negative integer" },
                       -owner   => 'CPAN',
                       -description => "Value is a negative Integer",
    },
    Float =>         { -name    => 'Float',
                       -as      => 'Filled',
                       -where   => sub { /^[\+\-]?\d+(\.\d+)?([Ee][\+-]?\d+)?$/ },
                       -message => sub { "value $_ is not a float" },
                       -owner   => 'CPAN',
                       -description => "Value is a floating number with optional exponent",
    },
    PositiveFloat => { -name    => 'PositiveFloat',
                       -as      => 'Float',
                       -where   => sub { $_ > 0 },
                       -message => sub { "value $_ is not a positive float" },
                       -owner   => 'CPAN',
                       -description => "Value is a positive floating number with optional exponent",
    },
    NegativeFloat => { -name    => 'NegativeFloat',
                       -as      => 'Float',
                       -where   => sub { $_ < 0 },
                       -message => sub { "value $_ is not a negative float" },
                       -owner   => 'CPAN',
                       -description => "Value is a negative floating number with optional exponent",
    },
};

# ------------------------------------------------------------------------------
#
# gets content of ref container
#
# ------------------------------------------------------------------------------

$get_content_subs = {
        HASH  => sub { my @keys = keys %$_; return scalar @keys ? \@keys: undef; },
        ARRAY => sub { return scalar @$_ ? $_: undef; },
};

# ------------------------------------------------------------------------------
#
# special rules (combined and other), not changable
#
# ------------------------------------------------------------------------------

$special_rules = {
    -Optional => {
        -value_position => 3,
        -code           => sub {
            # my  $subject_info = shift || '';
            # my  $rule_info    = shift;
            local $_            = $_[2];

            # skip one param if special rule follows
            my $special_rule = $special_rules->{$_[1]};
            if ($special_rule) {
                $_ = $_[$special_rule->{-value_position}];
            }
            ;

            return $_ if !defined $_; # value not set
            return validate(@_);
        }
    },
    -Default => {
        -value_position => 4,
        -code           => sub {
            my  $subject_info = shift || '';
            my  $default      = shift;
            my  $rule_info    = shift;
            # local $_          = $_[3];

            my $value_idx = 0;

            # --- skip x params if special rule follows ---
            my $special_rule = $special_rules->{$rule_info};
            if ($special_rule) {
                my $special_idx = $special_rule->{-value_position};
                $value_idx = $special_idx - 2 if $special_idx >= 0;
            }

            my $value = $_[$value_idx];

            # --- value set, validate it ---
            return validate($subject_info, $rule_info, @_)
                if (defined $value && $value ne '');

            # --- value not set ----
            unless (defined $default) {
                $trouble_level++;
                $fail_action->("Rules: Default value for rule -Default not set!");
                return $_;
            }

            if (ref($default) eq 'CODE') {
                $default = $default->();
            }

            return $default unless $validate_defaults;

            my @args = @_;

            $args[$value_idx] = $default;

            # --- default has also to be validated!! ---
            return validate($subject_info, $rule_info, @args)
        }
    },
    -And => {
        -value_position => 3,
        -code           => sub {
            my    $subject_info = shift || '';
            my    $rule_list    = shift;
            local $_            = shift;
            my    $message_ref  = shift;

            my $rule_exists  = 0;
            my $orig_value   = $_;

            foreach my $rule (@$rule_list) {
                if (!defined $rule || $rule eq '') {
                    $trouble_level++;
                    $fail_action->("Rules: rule for validation not set");
                    next        # in case of fail action doesn't die
                }

                if ($rule) {
                    my $special_rule = $special_rules->{$rule};

                    if ($special_rule) {
                        $trouble_level++;
                        $fail_action->("Rules: cannot call any special rule inside of rule '-And'\n");
                        next;
                    }

                    validate ($subject_info, $rule, $_, $message_ref);
                    $rule_exists = 1;
                }
            }

            $trouble_level++;
            $fail_action->("Rules: No rule found in list to be validated") unless $rule_exists;

            return $orig_value;
        }
    },
    -Or => {
        -value_position => 3,
        -code           => sub {
            my    $subject_info = shift || '';
            my    $rule_list    = shift;
            local $_            = shift;
            my    $message_ref  = shift;

            my $rule_exists  = 0;
            my $orig_value   = $_;

            foreach my $rule_info (@$rule_list) {
                if (!defined $rule_info || $rule_info eq '') {
                    $trouble_level++;
                    $fail_action->("Rules: rule for validation not set");
                    next        # in case of fail action doesn't die
                }

                next unless $rule_info;

                my $rule_ref = $rule_store->{$rule_info};
                unless ($rule_ref) {
                    my $special_rule = $special_rules->{$rule_info};

                    if ($special_rule) {
                        $trouble_level++;
                        $fail_action->("Rules: cannot call any special rule inside of rule '-Or'\n");
                        next;
                    }

                    my $ref_type = ref ($rule_info);

                    unless ($ref_type) {
                        $trouble_level++;
                        $fail_action->("Rules: unknown rule '$rule_info' for validation");
                        next; # in case of fail action doesn't die
                    } elsif ($ref_type eq 'HASH') { # given rule
                        $rule_ref = $rule_info;
                        # TODO: validate rule ...
                    } elsif ($ref_type eq 'CODE') { # where condition for rule
                        $rule_ref = {
                            -where   => $rule_info,
                            -message => sub { "$_ does not match free defined rule" },
                        };
                    } else {
                        $trouble_level++;
                        $fail_action->("Rules: cannot handle ref type '$ref_type' of rule '$rule_info' for validation");
                        next;   # in case of fail action doesn't die
                    }
                }

                if ($rule_ref) {
                    my $test_message_ref = $message_ref || $rule_ref->{-message};

                    my $parent_is_valid = defined $rule_ref->{-as}
                        ? _check_parent_rules($rule_ref->{-as}, $_)
                            : 1;
                    return $orig_value if $parent_is_valid && $rule_ref->{-where}->();

                    $rule_exists = 1;
                }
            }

            $trouble_level++;
            $fail_action->("Rules: No rule found in list to be validated") unless $rule_exists;

            my $result = _do_fail($subject_info, $message_ref || sub { "No rule matched of [".join(', ', @$rule_list)."]";});
            return $result if defined $result;

            return $orig_value;
        }
    },
    -Enum => {
        -value_position => 3,
        -code           => sub {
            my    $subject_info = shift || '';
            my    $enum_ref     = shift;
            local $_            = shift;
            my    $message_ref  = shift;

            my $orig_value      = $_;

            my $arg_type = ref ($enum_ref);
            if ($arg_type eq 'ARRAY') {
                $enum_ref = { map {$_=> 1} @$enum_ref };
            }
            elsif ($arg_type ne 'HASH') {
                _do_fail($subject_info, sub {"-Enum needs HASH_ref as second parameter";});
            }

            unless (defined $_ && $enum_ref->{$_}) {
                my $result = _do_fail($subject_info, $message_ref ||
                             sub { "value $_ unknown, allowed values are: [ "
                                       .join (", ", sort (keys(%$enum_ref)))." ]"; }
                         );
                return $result if defined $result;

            }
            return $orig_value;
        }
    },
    -Range => {
        -value_position => 4,
        -code           => sub {
            my    $subject_info = shift || '';
            my    $range_ref    = shift;
            my    $rule         = shift;
            local $_            = shift;
            my    $message_ref  = shift;

            my $wrong_call_message_sub_ref
                = sub { "-Range needs ARRAY_ref containing two values [min max] as second parameter" };

            my $orig_value = $_;

            unless (ref($range_ref) eq 'ARRAY') {
                _do_fail($subject_info, $wrong_call_message_sub_ref);
                return $orig_value;
            }

            unless (scalar @$range_ref == 2) {
                _do_fail($subject_info, $wrong_call_message_sub_ref);
                return $orig_value;
            }

            my ($min, $max) = @$range_ref;
            if ($min > $max) {
                _do_fail($subject_info, sub { "(min) $min > $max (max) in range definition"; });
                return $orig_value;
            }

            # type check by is_valid to return here if fails
            my @messages;
            my $is_valid;
            {
                local ($message_store) = [];
                $is_valid = is_valid ($subject_info, $rule, $_, $message_ref);
                @messages = @{validation_messages()};
            }

            unless ($is_valid) {
                my $message = join ("\n", @messages);
                push (@$message_store, $message) if $message_store;
                $trouble_level++;
                my $result = $fail_action->($message);
                return $result if defined $result;

                return $orig_value;
            }

            unless ($min <= $_  &&  $_<= $max) {
                my $result = _do_fail($subject_info, sub {"value $_ is out of range [$min,$max]"});
                return $result if defined $result;
                return $orig_value;
            }

            return $orig_value;
        }
    },
    -RefEmpty => {
        -value_position => 3,
        -code => sub {

            my    $subject_info = shift || '';
            local $_            = shift;
            my    $message_ref  = shift;

            my $content_ref = _ref_empty_check($subject_info, $_, $message_ref);

            return undef unless defined $content_ref;

            my $count_results = scalar @$content_ref;
            return 0 unless $count_results;

            _do_fail($subject_info, sub { "Should be empty, but contains $count_results entries: [ ".
                                              join (", ", @$content_ref)." ];" });

            return $count_results;
        }
    },
};

# ------------------------------------------------------------------------------
#
# internal Methods
#
# ------------------------------------------------------------------------------

sub _handle_enum_explained {
    my $transform_key_ref = shift;
    my $transformed_text  = shift;
    my $rule_name         = shift;
    my @enum_args;
    my @enums_list;
    my %enums;

    foreach my $arg (@_) {
        if ($arg eq 1 or $arg eq 0) {
            # arg is complete
            my $last_idx = $#enum_args;

            if ($last_idx < 1) {
                $trouble_level++;
                $fail_action->("Rules: not enough configuration values for enum '$enum_args[0]'");
            }

            my $explanation = $enum_args[$last_idx];
            map { my $key = $transform_key_ref ? $transform_key_ref->($_): $_;
                  $enums{$key} = $explanation;
                  push (@enums_list, $key);
              } @enum_args[0..--$last_idx];
            @enum_args = ();
        }
        else {
            push (@enum_args, $arg);
        }
    }

    my $validation_sub_ref = $transform_key_ref
        ? sub { defined $_ && defined $enums{$transform_key_ref->($_)} }
            : sub { defined $_ && defined $enums{$_} };

    return ($rule_name,
            -where   => $validation_sub_ref,
            -enum    => \%enums,
            -message => sub { "$rule_name: value $_ unknown, allowed values$transformed_text ".
                                  "are: [ ".join (", ", @enums_list)." ]" }
        );
}

sub _check_parent_rules {
    my    $rule_name    = shift;
    local $_            = shift;

    my $orig_value      = $_;

    my $rule_ref = $rule_store->{$rule_name};

    unless ($rule_ref) {
        $trouble_level++;
        $fail_action->("Rules: unknown rule '$rule_name' for validation");
        return 0; # in case of fail action doesn't die
    }

    if (defined $rule_ref->{-as}) {
        return 0 unless _check_parent_rules($rule_ref->{-as}, $_);
    }

    return $rule_ref->{-where}->();
}

sub _ref_empty_check {
        my    $subject_info = shift || '';
        local $_            = shift;
        my    $message_ref  = shift;

        my $ref_type = ref($_);

        unless ($ref_type) {
                _do_fail($subject_info, sub { "Not a reference: $_" });
                return undef;
        }

        my $get_contents_ref = $get_content_subs->{$ref_type};

        unless ($get_contents_ref) {
                _do_fail($subject_info, sub { "could not check, if $ref_type is empty" });
                return undef;
        }

        return $get_contents_ref->();
}

sub _do_fail {
    my $subject_info = shift;
    my $message_ref  = shift;

    $trouble_level++;

    $_ = defined ($_) ? "'$_'" : '';

    my $message = $get_caller_info->()."($subject_info): ".$message_ref->();
    push (@$message_store, $message) if $message_store;

    return $fail_action->($message);
}

# ------------------------------------------------------------------------------
#
# API Methods
#
# ------------------------------------------------------------------------------

sub _init_run_API {
    *npar      = *named_parameter;

    *parameter = *_do_validate;
    *par       = *parameter;

    *validate  = *_do_validate;

    *p_end     = *parameters_end;

    *g_t       = *greater_than;
    *g_e       = *greater_equal;
    *l_t       = *less_than;
    *l_e       = *less_equal;

}

sub convert_to_named_params {
        my $array_ref = validate (args => ArrayRef => shift);

        validate (arg_count => Even => scalar @$array_ref =>
                                  sub { "Even number of args needed to build a hash, but arg-count = $_" });
        return @$array_ref;
}

sub parameters_end {
    my $container_ref = par (container_ref => -Or => [HashRef => 'ArrayRef'] => shift);
    my $message_text  = par (message_text  => Scalar => shift) || "extra parameters found";

    my $container_type = ref ($container_ref);
    if ($container_type eq 'ARRAY') {
        validate (parameters => sub { scalar @$container_ref == 0 } => $container_ref => sub { "$message_text: [ '".join ("', '", @$container_ref)."' ]"; });
        return scalar @$container_ref;
    }
    elsif ($container_type eq 'HASH') {
        my @arg_names = keys %$container_ref;
        validate (parameters => sub { scalar @arg_names == 0 } => $container_ref => sub { "$message_text: [ '".join ("', '", @arg_names)."' ]"; });
        return scalar @arg_names;
    }

    _do_fail("parameters_end()", sub { "unknown reference type $container_ref" });
    return -1;
}

# ------------------------------------------------------------------------------
#
# Messages and Validation Mode
#
# ------------------------------------------------------------------------------

sub validation_trouble {
    my $trouble_accepted = shift || 0;
    return $trouble_level > $trouble_accepted ? $trouble_level: 0;
}

sub validation_messages {
    my $mode = shift || '';

    return $message_store if !$message_store || !$mode || $mode ne '-clear';

    my @messages = @$message_store;
    @$message_store = ();
    return \@messages;
}

sub prepare_validation_mode {
    my $mode = lc(shift);

    my $new_fail_action = $fail_action;
    my $new_off         = $off;

    unless (is_valid(mode => -Enum => [ qw (die warn silent off) ] => $mode)) {
        $trouble_level++;
        croak "prepare_validation_mode(): unknown mode for Scalar::Validation selected: '$mode'";
    }

    # print "#### Select validation mode: $mode\n";

    if ($mode eq 'die') {
        $new_fail_action   = $croak_sub;
        $new_off = 0;
    }
    elsif ($mode eq 'warn') {
        $new_fail_action   = sub { carp "Warning: ", @_; return undef; };
        $new_off = 0;
    }
    elsif ($mode eq 'silent') {
        $new_fail_action   = sub { return undef; };
        $new_off = 0;
    }
    elsif ($mode eq 'off') {
        $new_fail_action = sub { return undef; };
        $new_off = 1;
    } else {
        # shouldn't be reached, just to be sure
        $trouble_level++;
        $fail_action->("prepare_validation_mode(): unknown validation mode $mode used");
    }

    return $new_fail_action, $new_off;
}

# ------------------------------------------------------------------------------
#
# Rules
#
# ------------------------------------------------------------------------------

sub get_rules {
    return $rule_store;
}

sub rule_known {
    my $rule = par (rule => Filled => shift, sub { "rule to search not set" });

    return $rule_store->{$rule} ? $rule : '';
}

sub declare_rule {
    my $rule_name    = par (rule => Filled => shift, sub { "rule to declare not set" });
    if (rule_known($rule_name)) { $fail_action->("rule '$rule_name': already defined"); }

    my %call_options = convert_to_named_params \@_;
    my %rule_options;

    $rule_options{-where} = npar (-where => CodeRef => \%call_options
        => sub { "rule '$rule_name': where condition"._defined_or_not_message($_, " is not a code reference: $_");});

    $rule_options{-message} = npar (-message => -Optional => CodeRef => \%call_options
        => sub { "rule '$rule_name': message"._defined_or_not_message($_, " is not a code reference: $_");})
           || sub { "Value $_ is not valid for rule '$rule_name'" };

    $rule_options{-as}           = npar (-as          => -Optional => String           => \%call_options);
    $rule_options{-enum}         = npar (-enum        => -Optional => HashRef          => \%call_options);
    $rule_options{-name}         = npar (-name        => -Default => $rule_name        => String  => \%call_options);
    $rule_options{-description } = npar (-description => -Default => "Rule $rule_name" => String  => \%call_options);
    $rule_options{-owner}        = npar (-owner       => -Default => 'CPAN'            => String  => \%call_options);

    parameters_end (\%call_options);

    $rule_store->{$rule_name} = \%rule_options;

    return $rule_name;
}

sub delete_rule {
    my $rule_name    = par (rule => Filled => shift, sub { "rule to delete not set" });

        validate (delete_rule => Defined => delete $rule_store->{$rule_name}
                                  => sub {"no rule $rule_name found to delete"});
        return $rule_name;
}

sub replace_rule {
        my $rule_name    = par (rule => Filled => shift, sub { "rule to replace not set" });

        return declare_rule(delete_rule($rule_name), @_);
}

# $_ is set to string '' in message part, if it was not defined
sub _defined_or_not_message {
        return " is missing" if '' eq shift;
        return shift;
}

# ------------------------------------------------------------------------------
#
# Dynamic rules
#
# ------------------------------------------------------------------------------

# --- Enum ---------------------------------------------------------------------------

sub Enum {
    my $rule_name  = shift;
    my %enums      = map { $_ => 1 } @_;
    my @enums_list = @_;

    return ($rule_name,
            -where   => sub { defined $_ && defined $enums{$_} },
            -enum    => \%enums,
            -message => sub { "$rule_name: value $_ unknown, allowed values are: [ ".join (", ", @enums_list)." ]" }
        );
}

sub enum {
    my $rule_name  = shift;
    my %enums      = map { lc($_) => 1 } @_;
    my @enums_list = map { lc($_)      } @_;

    return ($rule_name,
            -where   => sub { defined $_ && defined $enums{lc($_)} },
            -enum    => \%enums,
            -message => sub { "$rule_name: value $_ unknown, allowed values (transformed to lower case) are: [ ".join (", ", @enums_list)." ]" }
        );
}

sub Enum_explained {
    _handle_enum_explained(undef, "", @_);
}

sub enum_explained {
    _handle_enum_explained(sub { lc($_[0])}, " (transformed to lower case)", @_);
}

# --- numerical compare ---------------------------------------------------------------------------

sub greater_than {
    my $limit      = shift;
    my $type       = shift;
    return ({ -as    => $type,
              -where   => sub { $_ > $limit },
              -message => sub { "$_ > $limit failed. Value is not of type $type or not greater than limit."},
          },
            @_);
}

sub greater_equal {
    my $limit      = shift;
    my $type       = shift;
    return ({ -as    => $type,
              -where   => sub { $_ >= $limit },
              -message => sub { "$_ >= $limit failed. Value is not of type $type or not greater than limit."},
          },
            @_);
}

sub equal_to {
    my $compare      = shift;
    my $type         = shift;
    if ($type eq 'String') {
        return ({ -as    => $type,
                  -where   => sub { $_ eq $compare },
                  -message => sub { "$_ eq $compare failed. Value is not of type $type or different."},
              },
                @_);
    }

    return ({ -as    => $type,
              -where   => sub { $_ == $compare },
              -message => sub { "$_ == $compare failed. Value is not of type $type or different."},
          },
            @_);
}

sub less_than {
    my $limit      = shift;
    my $type       = shift;
    return ({ -as    => $type,
              -where => sub { $_ < $limit },
              -message => sub { "$_ < $limit failed. Value is not of type $type or not less than limit."},
          },
            @_);
}

sub less_equal {
    my $limit      = shift;
    my $type       = shift;
    return ({ -as    => $type,
              -where => sub { $_ <= $limit },
              -message => sub { "$_ <= $limit failed. Value is not of type $type or not less than limit."},
          },
            @_);
}

# --- ISA ---------------------------------------------------------------------------

sub is_a {
    my $type = shift;
    return ({ -as      => 'Class',
              -where   => sub { return $_->isa($type) },
              -message => sub { "$_ is not of class $type or derived from it."},
          },
            @_);
}

# ------------------------------------------------------------------------------
#
# Validation
#
# ------------------------------------------------------------------------------

# --- helpful for tests ------------------------------------------------

sub is_valid {
    my $valid = 1;

    local $fail_action   = sub { $valid = 0 };
    local $trouble_level = 0; # not to rise trouble level

    validate(@_);

    return $valid;
}

# --- return value           if valid   ---------------
# --- return corrected value if invalid   ---------------
sub validate_and_correct {
    my ($validation_options_ref,        # options for validate
        $options_ref
    ) = @_;

    my $correction_action = $options_ref->{-correction}; # action that does corrections in value

	my $validation_options_copied = 0;
	my $value_pos    = 2;
	my $special_rule = $special_rules->{$validation_options_ref->[1]};
	$value_pos = $special_rule->{-value_position} if $special_rule;

    unless (defined $validation_options_ref->[$value_pos]) {
		my $default = $options_ref->{-default};

		if (defined $default && $value_pos >= 0) {
			my @tmp_validation_options = @$validation_options_ref;
			$validation_options_ref    = \@tmp_validation_options;
			$validation_options_ref->[$value_pos] = $default;
			$validation_options_copied = 1;
		}
    }

    if ($correction_action) {
		my $orig_fail_action = $fail_action;
		my $correction_done  = 0;
		my $result = undef;
		{
			local ($fail_action) = sub {
				s/^'//o;
				s/'$//o;
				$correction_done = 1;
				$correction_action->($_);

			};
			$result = validate(@$validation_options_ref);
		}

		if ($correction_done) {
			# --- update arg vector by new value $result ---
			if ($value_pos >= 0){
				unless ($validation_options_copied) {
					my @corrected_validation_options = @$validation_options_ref;
					$validation_options_ref = \@corrected_validation_options;
				}
				$validation_options_ref->[$value_pos] = $result;
			}
		}
		else {
			my $print_result = defined ($result) ? "'$result'" : '';
			return $result;
		}
    }
    return validate(@$validation_options_ref);
}

# --- don't name key twice, deletes validated values out of hash -------------------------
#   named_parameter
sub named_parameter {
        my $first_arg = shift;
        my $hash_ref;

        my $msg_ref;
        my $key;
        my $option_args_ref;

        my $args_ref = \@_;

        unless (is_valid(key  => Scalar  => $first_arg)) {
                $args_ref        = validate (validation_args => ArrayRef => $first_arg);
                $key             = shift @$args_ref;
                $option_args_ref = shift;
        }
        else {
                $key = $first_arg;
        }

        $key = validate (key  => Scalar  => $key);

        $hash_ref = pop @$args_ref;

        unless (is_valid(option_ref => HashRef => $hash_ref)) {
                $msg_ref  = validate (message_ref => CodeRef => $hash_ref);
                $hash_ref = validate (option_ref  => HashRef => pop @$args_ref);
        }

        my $value = delete $hash_ref->{$key};

        unless (defined $value) {
                if ($option_args_ref) {
                        $value = $option_args_ref->{-default};
                        print "used default $key => '$value'\n";
                        # print $option_args_ref->{-description}."\n";
                }
        }

        return validate ($key, @$args_ref, $value, $msg_ref);
}

# --- return value        if valid   ---------------
# --- call   $fail_action if invalid ---------------
sub _do_validate {
    if ($off) {
        my $value_pos = 2;
        $value_pos = $special_rules->{$_[1]}->{-value_position} if $special_rules->{$_[1]};
        return $_[$value_pos] if $value_pos >= 0;
    }

    my    $subject_info = shift || '';
    my    $rule_info    = shift;

    unless ($rule_info) {
        $trouble_level++;
        $fail_action->("rule for validation not set");
        return $_; # in case of fail action doesn't die
    }

    my $rule_ref   = $rule_store->{$rule_info};

    unless ($rule_ref) {
        my $special_rule = $special_rules->{$rule_info}->{-code};

        return $special_rule->($subject_info, @_) if $special_rule;

        my $ref_type = ref ($rule_info);

        unless ($ref_type) {
            $trouble_level++;
            $fail_action->("unknown rule '$rule_info' for validation");
            return shift; # in case of fail action doesn't die
        }
        elsif ($ref_type eq 'HASH') { # given rule
            $rule_ref = $rule_info;
            # TODO: validate rule ...
        }
        elsif ($ref_type eq 'CODE') { # where condition for rule
            $rule_ref = {
                -where   => $rule_info,
                -message => sub { "$_ does not match free defined rule" },
            };
        }
        else {
            $trouble_level++;
            $fail_action->("Rules: cannot handle ref type '$ref_type' of rule '$rule_info' for validation");
            return shift; # in case of fail action doesn't die
        }
    }

    local $_            = shift;
    my    $message_ref  = shift;

    my $orig_value       = $_;
    my $test_message_ref = $message_ref || $rule_ref->{-message};

    my $parent_is_valid = defined $rule_ref->{-as}
        ? _check_parent_rules($rule_ref->{-as}, $_)
            : 1;

    unless ($parent_is_valid && $rule_ref->{-where}->()) {
        $_ = defined ($_) ? "'$_'" : '';
        my $message = $get_caller_info->()."($subject_info): ".$test_message_ref->();
        push (@$message_store, $message) if $message_store;
        $trouble_level++;
        my $result = $fail_action->($message);
        return $result if defined $result;
    }

    return $orig_value;
}

1;

__END__