package Brannigan::Validations;

our $VERSION = "0.9";
$VERSION = eval $VERSION;

use strict;
use warnings;

=head1 NAME

Brannigan::Validations - Built-in validation methods for Brannigan.

=head1 VERSION

version 0.9

=head1 DESCRIPTION

This module contains all built-in validation methods provided natively
by the L<Brannigan> input validation/parsing system.

=head1 GENERAL PURPOSE VALIDATION METHOD

All these methods receive the value of a parameter, and other values
that explicilty define the requirements. They return a true value if the
parameter's value passed the test, or a false value otherwise.

=head2 required( $value, $boolean )

If C<$boolean> has a true value, this method will check that a required
parameter was indeed provided; otherwise (i.e. if C<$boolean> is not true)
this method will simply return a true value to indicate success.

You should note that if a parameter is required, and a non-true value is
received (i.e. 0 or the empty string ""), this method considers the
requirement as fulfilled (i.e. it will return true). If you need to make sure
your parameters receive true values, take a look at the C<is_true()> validation
method.

Please note that if a parameter is not required and indeed isn't provided
with the input parameters, any other validation methods defined on the
parameter will not be checked.

=cut

sub required {
	my ($class, $value, $boolean) = @_;

	return if $boolean && !defined $value;

	return 1;
}

=head2 forbidden( $value, $boolean )

If C<$boolean> has a true value, this method will check that a forbidden
parameter was indeed NOT provided; otherwise (i.e. if C<$boolean> has a
false value), this method will do nothing and simply return true.

=cut

sub forbidden {
	my ($class, $value, $boolean) = @_;

	defined $value && $boolean ? return : 1;
}

=head2 is_true( $value, $boolean )

If C<$boolean> has a true value, this method will check that C<$value>
has a true value (so, C<$value> cannot be 0 or the empty string); otherwise
(i.e. if C<$boolean> has a false value), this method does nothing and
simply returns true.

=cut

sub is_true {
	my ($class, $value, $boolean) = @_;

	$boolean && !$value ? return : 1;
}

=head2 length_between( $value, $min_length, $max_length )

Makes sure the value's length (stringwise) is inside the range of
C<$min_length>-C<$max_length>, or, if the value is an array reference,
makes sure it has between C<$min_length> and C<$max_length> items.

=cut

sub length_between {
	my ($class, $value, $min, $max) = @_;

	my $length = ref $value eq 'ARRAY' ? @$value : length($value);

	$length < $min || $length > $max ? return : 1;
}

=head2 min_length( $value, $min_length )

Makes sure the value's length (stringwise) is at least C<$min_length>, or,
if the value is an array reference, makes sure it has at least C<$min_length>
items.

=cut

sub min_length {
	my ($class, $value, $min) = @_;

	my $length = ref $value eq 'ARRAY' ? @$value : length($value);

	return 1 unless defined $min && $min >= 0;

	!$value && $min || $length < $min ? return : 1;
}

=head2 max_length( $value, $max_length )

Makes sure the value's length (stringwise) is no more than C<$max_length>,
or, if the value is an array reference, makes sure it has no more than
C<$max_length> items.

=cut

sub max_length {
	my ($class, $value, $max) = @_;

	my $length = ref $value eq 'ARRAY' ? @$value : length($value);

	$length > $max ? return : 1;
}

=head2 exact_length( $value, $length )

Makes sure the value's length (stringwise) is exactly C<$length>, or,
if the value is an array reference, makes sure it has exactly C<$exact_length>
items.

=cut

sub exact_length {
	my ($class, $value, $exlength) = @_;

	return unless $value;

	my $length = ref $value eq 'ARRAY' ? @$value : length($value);

	$length != $exlength ? return : 1;
}

=head2 integer( $value, $boolean )

If boolean is true, makes sure the value is an integer.

=cut

sub integer {
	my ($class, $value, $boolean) = @_;

	$boolean && $value !~ m/^\d+$/ ? return : 1;
}

=head2 value_between( $value, $min_value, $max_value )

Makes sure the value is between C<$min_value> and C<$max_value>.

=cut

sub value_between {
	my ($class, $value, $min, $max) = @_;

	!defined($value) || $value < $min || $value > $max ? return : 1;
}

=head2 min_value( $value, $min_value )

Makes sure the value is at least C<$min_value>.

=cut

sub min_value {
	my ($class, $value, $min) = @_;

	$value < $min ? return : 1;
}

=head2 max_value( $value, $max )

Makes sure the value is no more than C<$max_value>.

=cut

sub max_value {
	my ($class, $value, $max) = @_;

	$value > $max ? return : 1;
}

=head2 array( $value, $boolean )

If C<$boolean> is true, makes sure the value is actually an array reference.

=cut

sub array {
	my ($class, $value, $boolean) = @_;

	$boolean ? ref $value eq 'ARRAY' ? 1 : return : ref $value eq 'ARRAY' ? return : 1;
}

=head2 hash( $value, $boolean )

If C<$boolean> is true, makes sure the value is actually a hash reference.

=cut

sub hash {
	my ($class, $value, $boolean) = @_;

	$boolean ? ref $value eq 'HASH' ? 1 : return : ref $value eq 'HASH' ? return : 1;
}

=head2 one_of( $value, @values )

Makes sure a parameter's value is one of the provided acceptable values.

=cut

sub one_of {
	my ($class, $value, @values) = @_;

	foreach (@values) {
		return 1 if $value eq $_;
	}

	return;
}

=head2 matches( $value, $regex )

Returns true if C<$value> matches the regular express (C<qr//>) provided.
Will return false if C<$regex> is not a regular expression.

=cut

sub matches {
	my ($class, $value, $regex) = @_;

	return unless ref $regex eq 'Regexp';
	$value =~ $regex ? 1 : return;
}

=head1 USEFUL PASSPHRASE VALIDATION METHODS

The following validations are useful for passphrase strength validations:

=head2 min_alpha( $value, $integer )

Returns a true value if C<$value> is a string that has at least C<$integer>
alphabetic (C<A-Z> and C<a-z>) characters.

=cut

sub min_alpha {
	my ($class, $value, $integer) = @_;

	my @matches = ($value =~ m/[A-Za-z]/g);

	scalar @matches >= $integer ? 1 : return;
}

=head2 max_alpha( $value, $integer )

Returns a true value if C<$value> is a string that has at most C<$integer>
alphabetic (C<A-Z> and C<a-z>) characters.

=cut

sub max_alpha {
	my ($class, $value, $integer) = @_;

	my @matches = ($value =~ m/[A-Za-z]/g);

	scalar @matches <= $integer ? 1 : return;
}

=head2 min_digits( $value, $integer )

Returns a true value if C<$value> is a string that has at least
C<$integer> digits (C<0-9>).

=cut

sub min_digits {
	my ($class, $value, $integer) = @_;

	my @matches = ($value =~ m/[0-9]/g);

	scalar @matches >= $integer ? 1 : return;
}

=head2 max_digits( $value, $integer )

Returns a true value if C<$value> is a string that has at most
C<$integer> digits (C<0-9>).

=cut

sub max_digits {
	my ($class, $value, $integer) = @_;

	my @matches = ($value =~ m/[0-9]/g);

	scalar @matches <= $integer ? 1 : return;
}

=head2 min_signs( $value, $integer )

Returns a true value if C<$value> has at least C<$integer> special or
sign characters (e.g. C<%^&!@#>, or basically anything that isn't C<A-Za-z0-9>).

=cut

sub min_signs {
	my ($class, $value, $integer) = @_;

	my @matches = ($value =~ m/[^A-Za-z0-9]/g);

	scalar @matches >= $integer ? 1 : return;
}

=head2 max_signs( $value, $integer )

Returns a true value if C<$value> has at most C<$integer> special or
sign characters (e.g. C<%^&!@#>, or basically anything that isn't C<A-Za-z0-9>).

=cut

sub max_signs {
	my ($class, $value, $integer) = @_;

	my @matches = ($value =~ m/[^A-Za-z0-9]/g);

	scalar @matches <= $integer ? 1 : return;
}

=head2 max_consec( $value, $integer )

Returns a true value if C<$value> does not have a sequence of consecutive
characters longer than C<$integer>. Consequtive characters are either
alphabetic (e.g. C<abcd>) or numeric (e.g. C<1234>).

=cut

sub max_consec {
	my ($class, $value, $integer) = @_;

	# the idea here is to break the string intoto an array of characters,
	# go over each character in the array, starting at the first one,
	# and making sure that character does not begin a sequence longer
	# than allowed ($integer). This means we have recursive loops here,
	# because for every character, we compare it to the following character
	# and while they form a sequence, we move to the next pair and compare
	# them until the sequence is broken. To make it a tad faster, our
	# outer loop won't go over the entire characters array, but only
	# up to the last character that might possibly form an invalid
	# sequence. This character would be positioned $integer+1 characters
	# from the end.

	my @chars = split(//, $value);
	for (my $i = 0; $i <= scalar(@chars) - $integer - 1; $i++) {
		my $fc = $i; # first character for comparison
		my $sc = $i + 1; # second character for comparison
		my $sl = 1; # sequence length
		while ($sc <= $#chars && ord($chars[$sc]) - ord($chars[$fc]) == 1) {
			# characters are in sequence, increase counters
			# and compare next pair
			$sl++;
			$fc++;
			$sc++;
		}
		return if $sl > $integer;
	}

	return 1;
}

=head2 max_reps( $value, $integer )

Returns a true value if C<$value> does not contain a sequence of a repeated
character longer than C<$integer>. So, for example, if C<$integer> is 3,
then "aaa901" will return true (even though there's a repetition of the
'a' character it is not longer than three), while "9bbbb01" will return
false.

=cut

sub max_reps {
	my ($class, $value, $integer) = @_;

	# the idea here is pretty much the same as in max_consec but
	# we truely compare each pair of characters

	my @chars = split(//, $value);
	for (my $i = 0; $i <= scalar(@chars) - $integer - 1; $i++) {
		my $fc = $i; # first character for comparison
		my $sc = $i + 1; # second character for comparison
		my $sl = 1; # sequence length
		while ($sc <= $#chars && $chars[$sc] eq $chars[$fc]) {
			# characters are in sequence, increase counters
			# and compare next pair
			$sl++;
			$fc++;
			$sc++;
		}
		return if $sl > $integer;
	}

	return 1;
}

=head2 max_dict( $value, $integer, [ \@dict_files ] )

Returns a true value if C<$value> does not contain a dictionary word
longer than C<$integer>. By default, this method will look for the Unix
dict files C</usr/dict/words>, C</usr/share/dict/words> and C</usr/share/dict/linux.words>.
You can supply more dictionary files to look for with an array reference
of full paths.

So, for example, if C<$integer> is 3, then "a9dog51" will return true
(even though "dog" is a dictionary word, it is not longer than three),
but "a9punk51" will return false, as "punk" is longer.

WARNING: this method is known to not work properly when used in certain
environments such as C<PSGI>, I'm investigating the issue.

=cut

sub max_dict {
	my ($class, $value, $integer, $dict_files) = @_;

	# the following code was stolen from the CheckDict function of
	# Data::Password by Ariel Brosh (RIP) and Oded S. Resnik

	$dict_files ||= [];
	unshift(@$dict_files, qw!/usr/dict/words /usr/share/dict/words /usr/share/dict/linux.words!);

	foreach (@$dict_files) {
		open (DICT, $_) || next;
		while (my $dict_line = <DICT>) {
			chomp $dict_line;
			next if length($dict_line) <= $integer;
			if (index(lc($value), lc($dict_line)) > -1) {
				close(DICT);
				return;
			}
		}
		close(DICT);
	}

	return 1;
}

=head1 SEE ALSO

L<Brannigan>, L<Brannigan::Tree>.

=head1 AUTHOR

Ido Perlmuter, C<< <ido at ido50 dot net> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-brannigan at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Brannigan>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

	perldoc Brannigan::Validations

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Brannigan>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Brannigan>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Brannigan>

=item * Search CPAN

L<http://search.cpan.org/dist/Brannigan/>

=back

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Ido Perlmuter.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1;