File Coverage

blib/lib/Scalar/Validation.pm

Criterion	Covered	Total	%
statement	287	421	68.1
branch	88	138	63.7
condition	21	35	60.0
subroutine	69	97	71.1
pod	4	28	14.2
total	469	719	65.2

# perl
#
# Class Scalar::Validation
#
# Simple rule based validation package for scalar values
#
# Ralf Peine, Sat Oct 25 15:10:22 2014
#
# More documentation at the end of file
#------------------------------------------------------------------------------

$VERSION = "0.700";

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
                     p_start parameters_start convert_to_named_params parameters_end p_end
                     validation_trouble get_validation_trouble_level add_validation_trouble
                     validation_messages get_and_reset_validation_messages prepare_validation_mode
                     meta_info_clear build_meta_info_for_module end_meta_info_gen get_meta_info list_meta_info
);

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
                   p_start parameters_start convert_to_named_params parameters_end p_end
                   validation_trouble get_validation_trouble_level add_validation_trouble
                   validation_messages get_and_reset_validation_messages prepare_validation_mode
                   meta_info_clear build_meta_info_for_module end_meta_info_gen get_meta_info list_meta_info
)],);

use Carp;
# use Data::Dumper;

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

our $ignore_callers    = { __PACKAGE__ , 1 };
our $ignore_caller_pattern;

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();
}

_update_caller_pattern();

_init_private_calls();
_init_run_API();

# _init_doc_API();

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

our $call_info = '';

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_iter = 1;

    while ($sub_name =~ $ignore_caller_pattern) {
        ($module, $file_name, $line, $sub_name) = caller($call_level_iter++);
        $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;


my $class_meta_model = {};
my $doc_class_name;
my $doc_class_method;

# ------------------------------------------------------------------------------
#
# 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.",
    },
    ModuleName  =>   { -name    => 'ModuleName',
                       -as      => Filled =>
                       -where   => sub { /^\w+(::\w+)*$/;
                       },
                       -message => sub { "value $_ is not a module name like A::Ba::Cba" },
                       -owner   => 'CPAN',
                       -description => "Value is a module name like A::Ba::Cba.",
    },

    # --- 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(@_);
        },
	-print_args => sub {
	    eval {
		my $rule    = shift;

		return "-Optional [$rule]";
	    }
	}
    },
    -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)
        },
	-print_args => sub {
	    eval {
		my $default = shift;
		my $rule    = shift;

		return "-Default = '$default' [$rule]";
	    }
	}
    },
    -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;
        },
        -print_args => sub {
            my    $rule_list    = shift;

	    delete $rule_list->[$#$rule_list] unless $rule_list->[$#$rule_list];
	    my $arg_info = join (', ', @$rule_list);
	    $arg_info = 'no argument informations' unless $arg_info;

	    return "-And [$arg_info]";
	}
    },
    -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;
        },
        -print_args => sub {
            my    $rule_list    = shift;

	    delete $rule_list->[$#$rule_list] unless $rule_list->[$#$rule_list];
	    my $arg_info = join (', ', @$rule_list);
	    $arg_info = 'no argument informations' unless $arg_info;

	    return "-Or [$arg_info]";
	}
    },
    -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;
        },
        -print_args => sub {
            my $enum_ref = shift;

	    my $arg_info = 'no argument informations';
            my $arg_type = ref ($enum_ref);
            if ($arg_type eq 'ARRAY') {
		$arg_info = join (', ', @$enum_ref);
            }
            elsif ($arg_type eq 'HASH') {
		$arg_info = join (', ', sort(keys(%$enum_ref)));
            }
	    return "Enum [$arg_info]";
	}
    },
    -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;
        },
        -print_args => sub {
            my    $range_ref    = shift;
            my    $rule         = shift;
	    my    $min          = $range_ref->[0];
	    my    $max          = $range_ref->[1];
	    return "Range [$min,$max] of type $rule";
	}
    },
    -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;
        },
        -print_args => sub {
	    return "EmptyReference";
	}
    },
};

# ------------------------------------------------------------------------------
#
# 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->()."($call_info$subject_info): ".$message_ref->();
    push (@$message_store, $message) if $message_store;

    return $fail_action->($message);
}

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

sub _init_run_API {
    *p_start          = *_do_parameters_start;
    *parameters_start = *_do_parameters_start;

    *p_end            = *_do_parameters_end;
    *parameters_end   = *_do_parameters_end;

    *npar             = *_do_named_parameter;
    *named_parameter  = *_do_named_parameter;

    *parameter        = *_do_validate_parameter;
    *par              = *_do_validate_parameter;

    *validate         = *_do_validate_call;
    *is_valid         = *_do_is_valid;

    *get_api_doc      = *get_api_documentation;

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

}

sub _init_private_calls {
    *_p_npar             = *_do_named_parameter;
    *_p_named_parameter  = *_do_named_parameter;

    *_p_parameter        = *_do_validate_parameter;
    *_p_par              = *_do_validate_parameter;

    *_p_validate         = *_do_validate_call;
    *_p_is_valid         = *_do_is_valid;
}

sub _get_meta_extraction_code {
    my $module_name = shift;
    return "
    use $module_name;
    *".$module_name."::p_start          = *".__PACKAGE__."::_start_sub_meta_extraction;
    *".$module_name."::parameters_start = *".__PACKAGE__."::_start_sub_meta_extraction;

    *".$module_name."::p_end            = *".__PACKAGE__."::_end_sub_meta_extraction;
    *".$module_name."::parameters_end   = *".__PACKAGE__."::_end_sub_meta_extraction;

    *".$module_name."::npar             = *".__PACKAGE__."::_sub_meta_extract_named_parameter;
    *".$module_name."::named_parameter  = *".__PACKAGE__."::_sub_meta_extract_named_parameter;

    *".$module_name."::parameter        = *".__PACKAGE__."::_sub_meta_extract_positional_parameter;
    *".$module_name."::par              = *".__PACKAGE__."::_sub_meta_extract_positional_parameter;

    *".$module_name."::validate         = *".__PACKAGE__."::_sub_meta_no_extraction;
";
}

sub _reset_validation_code {
    my $module_name = shift;
    return "
    use $module_name;
    *".$module_name."::p_start          = *".__PACKAGE__."::_do_parameters_start;
    *".$module_name."::parameters_start = *".__PACKAGE__."::_do_parameters_start;

    *".$module_name."::p_end            = *".__PACKAGE__."::_do_parameters_end;
    *".$module_name."::parameters_end   = *".__PACKAGE__."::_do_parameters_end;

    *".$module_name."::npar             = *".__PACKAGE__."::_do_named_parameter;
    *".$module_name."::named_parameter  = *".__PACKAGE__."::_do_named_parameter;

    *".$module_name."::parameter        = *".__PACKAGE__."::_do_validate_parameter;
    *".$module_name."::par              = *".__PACKAGE__."::_do_validate_parameter;

    *".$module_name."::validate         = *".__PACKAGE__."::_do_validate_call;
";
}

sub _do_parameters_start {
    return $trouble_level;
}

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

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

sub _do_parameters_end {

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

    my $container_type = ref ($container_ref);
    if ($container_type eq 'ARRAY') {
        _p_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;
        _p_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;
}

# ------------------------------------------------------------------------------
#
# Meta Information Mode
#
# ------------------------------------------------------------------------------

sub meta_info_clear {
    print "# Start API documentation ==============================\n";
    $class_meta_model = {};
}

sub build_meta_info_for_module {
    end_meta_info_gen();
    $doc_class_name = _p_par(module_name => ModuleName => shift);
    my $instance_creator = _p_par(instance_creation => -Optional => CodeRef => shift);

    # --- run sub -------------------------------------------------

    # print "# Module: $doc_class_name; # ==============================\n";
    $class_meta_model->{$doc_class_name} = {};
    $class_meta_model->{$doc_class_name}->{subs} = {};
    eval (_get_meta_extraction_code($doc_class_name)); print $@ if $@;

    $instance_creator = eval ('sub { return '.$doc_class_name.'->new(); }')
	unless $instance_creator;

    return $instance_creator->();
}

sub end_meta_info_gen {
    eval (_reset_validation_code($doc_class_name)) if $doc_class_name; print $@ if $@;
}

sub get_meta_info {
    return $class_meta_model;
}

sub list_meta_info {
    my @meta_info_list;

    foreach my $pm (sort (keys (%$class_meta_model))) {
	my $subs     = $class_meta_model->{$pm}->{subs};

	foreach my $sub_name (sort (keys (%$subs))) {
	    my $parameters = $subs->{$sub_name}->{params};
	    my %sub_info = (module => $pm,
			    sub => $sub_name);

	    if (scalar (@$parameters)) {
		foreach my $parameter (@$parameters) {
		    my %par_info = (%$parameter, %sub_info);
		    push (@meta_info_list, \%par_info);
		}
	    }
	    else { # sub has no parameters
		$sub_info{rule} = $sub_info{kind} = $sub_info{name} = '';
		push (@meta_info_list, \%sub_info);
	    }
	}
    }

    return \@meta_info_list;
}

sub _start_sub_meta_extraction { # parameters_start
    $doc_class_method = $get_caller_info->();
    $doc_class_method =~ s/.*\:\://og;
    $class_meta_model->{$doc_class_name}->{subs}->{$doc_class_method} = {};
    $class_meta_model->{$doc_class_name}->{subs}->{$doc_class_method}->{params} = [];
    # print "\tMethod: $doc_class_method  # ---------------------------------------\n";
    return 0;
}

sub _end_sub_meta_extraction { # parameters_end
    # print "\t# --- end method documentation ---\n";
    $trouble_level++;
    return 0;
}

sub _sub_meta_extract_named_parameter { # named_parameter
    my $argument_infos = _api_doc_get_argument_info(@_);
    push (@{$class_meta_model->{$doc_class_name}->{subs}->{$doc_class_method}->{params}},
	  {
	      kind => Named =>
	      name => $argument_infos->[0],
	      rule => $argument_infos->[1],
	  }
	);

    local ($Scalar::Validation::off) = 1;
    $trouble_level++;
    return _do_named_parameter(@_);
}

sub _sub_meta_extract_positional_parameter { # parameter
    my $argument_infos = _api_doc_get_argument_info(@_);
    # print "\t\tPositional Parameter: $argument_info_str\n";
    push (@{$class_meta_model->{$doc_class_name}->{subs}->{$doc_class_method}->{params}},
	  {
	      kind => Positional =>
	      name => $argument_infos->[0],
	      rule => $argument_infos->[1],
	  }
	);

    local ($Scalar::Validation::off) = 1;
    $trouble_level++;
    return _do_validate_parameter(@_);
}

sub _sub_meta_no_extraction { # validate
    # print "_sub_meta_no_extraction ".join (', ', @_)."\n";
    local ($Scalar::Validation::off) = 1;
    $trouble_level++;
    return _do_validate_call(@_);
}

sub _api_doc_get_argument_info {
    my $name      = 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};

    my $rule_info_string = 'No info for rule';

    if ($rule_ref) {
	$rule_info_string = $rule_ref->{-name};
    }
    else {
	my $special_rule_name = $rule_info;
	# print "$rule_info, ".join(', ', @_)."\n";
	$rule_ref = $special_rules->{$special_rule_name};
	if ($rule_ref) {
	    my $last_idx = scalar(@_);
	    if ($last_idx >= 0) {
		my $print_args = $rule_ref->{-print_args};
		if ($print_args) {
		    $rule_info_string = $print_args->(@_);
		}
		else {
		    $fail_action->("print_args missing for rule '$special_rule_name'");
		}
	    }
	}
    }

    unless ($rule_ref) {
        my $ref_type = ref ($rule_info);

        unless ($ref_type) {
            $trouble_level++;
	    my $error_message = "unknown rule '$rule_info' for validation";
            $fail_action->($error_message);
            return [$error_message];
        }
        elsif ($ref_type eq 'HASH') { # given rule
            $rule_ref = $rule_info;
            # TODO: _p_validate rule ...
        }
        elsif ($ref_type eq 'CODE') { # where condition for rule
            $rule_ref = {
                -name => 'anonymous private rule'
            };
        }
        else {
            $trouble_level++;
	    my $error_message = "Rules: cannot handle ref type '$ref_type' of rule '$rule_info' for validation";
            $fail_action->$error_message();
            return [$error_message]; # in case of fail action doesn't die
        }
	$rule_info_string = $rule_ref->{-name};
    }

    return [$name, $rule_info_string];

}

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

sub add_validation_trouble {
    my ($value
        ) = @_;

    $trouble_level += ($value || 1);
}

sub get_validation_trouble_level {
    return $trouble_level;
}

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 (_p_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 = _p_par (rule => Filled => shift, sub { "rule to search not set" });

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

sub declare_rule {
    my $rule_name    = _p_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} = _p_npar (-where => CodeRef => \%call_options
        => sub { "rule '$rule_name': where condition"._defined_or_not_message($_, " is not a code reference: $_");});

    $rule_options{-message} = _p_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}           = _p_npar (-as          => -Optional => String           => \%call_options);
    $rule_options{-enum}         = _p_npar (-enum        => -Optional => HashRef          => \%call_options);
    $rule_options{-name}         = _p_npar (-name        => -Default  => $rule_name        => String  => \%call_options);
    $rule_options{-description } = _p_npar (-description => -Default  => "Rule $rule_name" => String  => \%call_options);
    $rule_options{-owner}        = _p_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    = _p_par (rule => Filled => shift, sub { "rule to delete not set" });

        _p_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    = _p_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 ({ -name    => "IsClass '$type'",
              -as      => 'Class',
              -where   => sub { return $_->isa($type) },
              -message => sub { "$_ is not of class $type or derived from it."},
          },
            @_);
}

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

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

sub _do_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 -------------------------
#   _do_named_parameter
sub _do_named_parameter {
        my $first_arg = shift;
        my $hash_ref;

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

        my $args_ref = \@_;

        $call_info = '';

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

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

        $hash_ref = pop @$args_ref;

        unless (_p_is_valid(option_ref => HashRef => $hash_ref)) {
	    $msg_ref  = _p_validate (message_ref => CodeRef => $hash_ref);
	    $hash_ref = _p_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 _p_validate ($key, @$args_ref, $value, $msg_ref);
}

# --- return value        if valid   ---------------
# --- call   $fail_action if invalid ---------------

sub _do_validate_parameter {
    $call_info = 'parameter ';
    goto &_do_validate;
}

sub _do_validate_call {
    $call_info = '';
    goto &_do_validate;
}

sub _do_validate {
    if ($off) {
        my $value_pos = 2;
	my $special_rule = $special_rules->{$_[1]};
        $value_pos = $special_rule->{-value_position} if $special_rule;
        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: _p_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->()."($call_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__