File Coverage

blib/lib/Brannigan/Tree.pm

Criterion	Covered	Total	%
statement	161	171	94.1
branch	118	128	92.1
condition	64	78	82.0
subroutine	12	12	100.0
pod	4	4	100.0
total	359	393	91.3

package Brannigan::Tree;

our $VERSION = "1.1";
$VERSION = eval $VERSION;

use strict;
use warnings;
use Brannigan::Validations;

=head1 NAME

Brannigan::Tree - A Brannigan validation/parsing scheme tree, possibly built from a series of inherited schemes.

=head1 VERSION

version 1.1

=head1 DESCRIPTION

This module is used internally by L. Basically, a tree is a
validation/parsing scheme in its "final", workable structure, taking
any inherited schemes into account. The actual validation and parsing
of input is done by this module.

=head1 CONSTRUCTOR

=head2 new( $scheme | @schemes )

Creates a new Brannigan::Tree instance from one or more schemes.

=cut

sub new {
	my $class = shift;

	return bless $class->_merge_trees(@_), $class;
}

=head1 OBJECT METHODS

=head2 process( \%params )

Validates and parses the hash-ref of input parameters. Returns a hash-ref
of the parsed input, possibly containing a '_rejects' hash-ref with a list
of failed validations for each failed parameter.

=cut

sub process {
	my ($self, $params) = @_;

	# validate the data
	my $data = {};

	my $rejects = $self->validate($params, $self->{params});
	$data->{_rejects} = $rejects if $rejects;

	my $prs = $self->parse($params, $self->{params}, $self->{groups});
	foreach (sort keys %$prs) {
		$data->{$_} = $prs->{$_};
	}

	return $data;
}

=head2 validate( \%params )

Validates the hash-ref of input parameters and returns a hash-ref of rejects
(i.e. failed validation methods) for each parameter.

=cut

sub validate {
	my ($self, $params, $rules) = @_;

	my $rejects;

	# go over all the parameters and validate them
	foreach (sort keys %$params) {
		# find references to this parameter, first in regexes, then direct
		# give preference to the direct references
		my @references;
		push(@references, $rules->{_all}) if $rules->{_all};
		foreach my $param (sort keys %$rules) {
			next unless $param =~ m!^/([^/]+)/$!;
			my $re = qr/$1/;
			push(@references, $rules->{$param}) if m/$re/;
		}
		push(@references, $rules->{$_}) if $rules->{$_};

		my $rj = $self->_validate_param($_, $params->{$_}, $self->_merge_trees(@references));

		$rejects->{$_} = $rj if $rj;
	}

	# find required parameters that aren't there
	foreach (sort keys %$rules) {
		next if $_ eq '_all';
		next if m!^/[^/]+/$!;
		$rejects->{$_} = ['required(1)'] if $rules->{$_}->{required} && (!defined $params->{$_} || $params->{$_} eq '');
	}

	return $rejects;
}

=head2 parse( \%params, \%param_rules, [\%group_rules] )

Receives a hash-ref of parameters, a hash-ref of parameter rules (this is
the 'params' part of a scheme) and optionally a hash-ref of group rules
(this is the 'groups' part of a scheme), parses the parameters according
to these rules and returns a hash-ref of all the parameters after parsing.

=cut

sub parse {
	my ($self, $params, $param_rules, $group_rules) = @_;

	my $data;

	# fill-in missing parameters with default values, if defined
	foreach (sort keys %$param_rules) {
		next if m!^/[^/]+/$!;
		next unless !defined $params->{$_} || $params->{$_} eq '';

		# is there a default value/method?
		if (exists $param_rules->{$_}->{default} && ref $param_rules->{$_}->{default} eq 'CODE') {
			$data->{$_} = $param_rules->{$_}->{default}->();
		} elsif (exists $param_rules->{$_}->{default}) {
			$data->{$_} = $param_rules->{$_}->{default};
		}
	}

	# parse the data
	foreach (sort keys %$params) {
		# ignore undefined or empty values
		next if !defined $params->{$_} || $params->{$_} eq '';

		# is there a reference to this parameter in the scheme?
		my @refs;
		foreach my $p (sort keys %$param_rules) {
			next unless $p =~ m!^/([^/]+)/$!;
			my $re = qr/$1/;
			next unless m/$re/;
			push(@refs, $param_rules->{$p});
		}
		push(@refs, $param_rules->{$_}) if $param_rules->{$_};

		next if scalar @refs == 0 && $self->{ignore_missing};
		unless (scalar @refs && $self->{ignore_missing}) {
			# pass the parameter as is
			$data->{$_} = $params->{$_};
			next;
		}

		# is this a hash-ref or an array-ref or just a scalar?
		if (ref $params->{$_} eq 'HASH') {
			my $pd = $self->parse($params->{$_}, $self->_merge_trees(@refs)->{keys});
			foreach my $k (sort keys %$pd) {
				$data->{$_}->{$k} = $pd->{$k};
			}
		} elsif (ref $params->{$_} eq 'ARRAY') {
			foreach my $val (@{$params->{$_}}) {
				# we need to parse this value with the rules
				# in the 'values' key
				my $pd = $self->parse({ param => $val }, { param => $self->_merge_trees(@refs)->{values} });
				push(@{$data->{$_}}, $pd->{param});
			}
		} else {
			# is there a parsing method?
			# first see if there's one in a regex
			my $parse;
			my @data = ($params->{$_});
			foreach my $r (sort keys %$param_rules) {
				next unless $r =~ m!^/([^/]+)/$!;
				my $re = qr/$1/;

				my @matches = (m/$re/);
				next unless scalar @matches > 0;
				push(@data, @matches);

				$parse = $param_rules->{$r}->{parse} if $param_rules->{$r}->{parse};
			}
			$parse = $param_rules->{$_}->{parse} if $param_rules->{$_}->{parse};

			# make sure if we have a parse method that is indeed a subroutine
			if ($parse && ref $parse eq 'CODE') {
				my $parsed = $parse->(@data);
				foreach my $k (sort keys %$parsed) {
					if (ref $parsed->{$k} eq 'HASH') {
						foreach my $sk (sort keys %{$parsed->{$k}}) {
							$data->{$k}->{$sk} = $parsed->{$k}->{$sk};
						}
					} elsif (ref $parsed->{$k} eq 'ARRAY') {
						push(@{$data->{$k}}, @{$parsed->{$k}});
					} else {
						$data->{$k} = $parsed->{$k};
					}
				}
			} else {
				# just pass as-is
				$data->{$_} = $params->{$_};
			}
		}
	}

	# parse group data
	if ($group_rules) {
		foreach (sort keys %$group_rules) {
			my @data;

			# do we have a list of parameters, or a regular expression?
			if (exists $group_rules->{$_}->{params}) {
				foreach my $p (@{$group_rules->{$_}->{params}}) {
					push(@data, $data->{$p});
				}
			} elsif (exists $group_rules->{$_}->{regex}) {
				my ($re) = ($group_rules->{$_}->{regex} =~ m!^/([^/]+)/$!);
				next unless $re;
				$re = qr/$re/;
				foreach my $p (sort keys %$data) {
					next unless $p =~ m/$re/;
					push(@data, $data->{$p});
				}
			} else {
				# we have nothing in this group
				next;
			}

			# parse the data
			my $parsed = $group_rules->{$_}->{parse}->(@data);
			foreach my $k (sort keys %$parsed) {
				if (ref $parsed->{$k} eq 'ARRAY') {
					push(@{$data->{$k}}, @{$parsed->{$k}});
				} elsif (ref $parsed->{$k} eq 'HASH') {
					foreach my $sk (sort keys %{$parsed->{$k}}) {
						$data->{$k}->{$sk} = $parsed->{$k}->{$sk};
					}
				} else {
					$data->{$k} = $parsed->{$k};
				}
			}
		}
	}

	return $data;
}

#############################
##### INTERNAL METHODS ######
#############################

# _validate_param( $param, $value, \%validations )
# ------------------------------------------------
# Receives the name of a parameter, its value, and a hash-ref of validations
# to assert against. Returns a list of validations that failed for this
# parameter. Depending on the type of the parameter (either scalar, hash
# or array), this method will call one of the following three methods.

sub _validate_param {
	my ($self, $param, $value, $validations) = @_;

	# is there any reference to this parameter in the scheme?
	return unless $validations;

	# is this parameter required? if not, and it has no value
	# (either undef or an empty string), then don't bother checking
	# any validations. If yes, and it has no value, do the same.
	return if !$validations->{required} && (!defined $value || $value eq '');
	return ['required(1)'] if $validations->{required} && (!defined $value || $value eq '');

	# is this parameter forbidden? if yes, and it has a value,
	# don't bother checking any other validations.
	return ['forbidden(1)'] if $validations->{forbidden} && defined $value && $value ne '';

	# is this a scalar, array or hash parameter?
	if ($validations->{hash}) {
		return $self->_validate_hash($param, $value, $validations);
	} elsif ($validations->{array}) {
		return $self->_validate_array($param, $value, $validations);
	} else {
		return $self->_validate_scalar($param, $value, $validations);
	}
}

# _validate_scalar( $param, $value, \%validations, [$type] )
# ----------------------------------------------------------
# Receives the name of a parameter, its value, and a hash-ref of validations
# to assert against. Returns a list of all failed validations for this
# parameter. If the parameter is a child of a hash/array parameter, then
# C<$type> must be provided with either 'hash' or 'array'.

sub _validate_scalar {
	my ($self, $param, $value, $validations, $type) = @_;

	my @rejects;

	# get all validations we need to perform
	foreach my $v (sort keys %$validations) {
		# skip the parse method and the default value
		next if $v eq 'parse' || $v eq 'default';
		next if $type && $type eq 'array' && $v eq 'values';
		next if $type && $type eq 'hash' && $v eq 'keys';

		# get the data we're passing to the validation method
		my @data = ref $validations->{$v} eq 'ARRAY' ? @{$validations->{$v}} : ($validations->{$v});

		# which validation method are we gonna use?
		# custom ones have preference
		if ($v eq 'validate' && ref $validations->{$v} eq 'CODE') {
			# this is an "inline" validation method, invoke it
			push(@rejects, $v) unless $validations->{$v}->($value, @data);
		} elsif (exists $self->{_custom_validations} && exists $self->{_custom_validations}->{$v} && ref $self->{_custom_validations}->{$v} eq 'CODE') {
			# this is a cross-scheme custom validation method
			push(@rejects, $v.'('.join(', ', @data).')') unless $self->{_custom_validations}->{$v}->($value, @data);
		} else {
			# we're using a built-in validation method
			push(@rejects, $v.'('.join(', ', @data).')') unless Brannigan::Validations->$v($value, @data);
		}
	}

	return scalar @rejects ? [@rejects] : undef;
}

# _validate_array( $param, $value, \%validations )
# ------------------------------------------------
# Receives the name of an array parameter, its value, and a hash-ref of validations
# to assert against. Returns a list of validations that failed for this
# parameter.

sub _validate_array {
	my ($self, $param, $value, $validations) = @_;

	# if this isn't an array, don't bother checking any other validation method
	return { _self => ['array(1)'] } unless ref $value eq 'ARRAY';

	# invoke validations on the parameter itself
	my $rejects = {};
	my $_self = $self->_validate_scalar($param, $value, $validations, 'array');
	$rejects->{_self} = $_self if $_self;

	# invoke validations on the values of the array
	my $i = 0;
	foreach (@$value) {
		my $rj = $self->_validate_param("${param}[$i]", $_, $validations->{values});
		$rejects->{$i} = $rj if $rj;
		$i++;
	}

	return scalar keys %$rejects ? $rejects : undef;
}

# _validate_hash( $param, $value, \%validations )
# -----------------------------------------------
# Receives the name of a hash parameter, its value, and a hash-ref of validations
# to assert against. Returns a list of validations that failed for this
# parameter.

sub _validate_hash {
	my ($self, $param, $value, $validations) = @_;

	# if this isn't a hash, don't bother checking any other validation method
	return { _self => ['hash(1)'] } unless ref $value eq 'HASH';

	# invoke validations on the parameter itself
	my $rejects = {};
	my $_self = $self->_validate_scalar($param, $value, $validations, 'hash');
	$rejects->{_self} = $_self if $_self;

	# invoke validations on the keys of the hash (a.k.a mini-params)
	my $hr = $self->validate($value, $validations->{keys});

	foreach (sort keys %$hr) {
		$rejects->{$_} = $hr->{$_};
	}

	return scalar keys %$rejects ? $rejects : undef;
}

# _merge_trees( @trees )
# ----------------------
# Merges two or more hash-refs of validation/parsing trees and returns the
# resulting tree. The merge is performed in order, so trees later in the
# array (i.e. on the right) "tramp" the trees on the left.

sub _merge_trees {
	my $class = shift;

	return unless scalar @_ && (ref $_[0] eq 'HASH' || ref $_[0] eq 'Brannigan::Tree');

	# the leftmost tree is the starting tree
	my $tree = shift;
	my %tree = %$tree;

	# now for the merging business
	foreach (@_) {
		next unless ref $_ eq 'HASH';

		foreach my $k (sort keys %$_) {
			if (ref $_->{$k} eq 'HASH') {
				unless (exists $tree{$k}) {
					$tree{$k} = $_->{$k};
				} else {
					$tree{$k} = $class->_merge_trees($tree{$k}, $_->{$k});
				}
			} else {
				if ($k eq 'forbidden' && $_->{$k}) {
					# remove required, if there was such a rule
					delete $tree{'required'};
				} elsif ($k eq 'required' && $_->{$k}) {
					# remove forbidden, if there was such a rule
					delete $tree{'forbidden'};
				}
				$tree{$k} = $_->{$k};
			}
		}
	}

	return \%tree;
}

=head1 SEE ALSO

L, L.

=head1 AUTHOR

Ido Perlmuter, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  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::Tree

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 LICENSE AND COPYRIGHT

Copyright 2010-2013 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;