File Coverage

blib/lib/Data/Classifier.pm

Criterion	Covered	Total	%
statement	79	100	79.0
branch	24	34	70.5
condition	3	3	100.0
subroutine	11	13	84.6
pod	5	8	62.5
total	122	158	77.2

package Data::Classifier;

our $VERSION = '0.01';

use strict;
use warnings;

use Carp qw(croak);
use YAML qw(LoadFile Load);

use Data::Classifier::Result;

#public interface
sub new {
	my ($class, %opts) = @_;
	my $self = {};

	bless($self, $class);

	if (defined($opts{file})) {
		$self->{TREE} = LoadFile($opts{file});
	} elsif (defined($opts{yaml})) {
		$self->{TREE} = Load($opts{yaml});
	} elsif (defined($opts{tree})) {
		$self->{TREE} = $opts{tree};
	} else {
		croak "You must specify one of file, yaml, or tree";
	}

	$self->{DEBUG} = $opts{debug};

	return $self;
}

sub process {
	my ($self, $attributes) = @_;
	my ($result, $result_class);

	$self->debug("starting classification");

	$self->{CLASS_STACK} = [];

	$self->recursive_search($attributes, $self->{TREE});

	$result = $self->{CLASS_STACK};

	$self->{CLASS_STACK} = undef;

	$self->debug("classification done\n\n");

	return $self->return_result($result);
}

#this method should be overloaded by base classes to change the class
#that is returned by process
sub return_result {
	my ($self, $result) = @_;
	return Data::Classifier::Result->new($result);
}

sub dump {
	my ($self) = @_;

	return Dumper($self->{TREE});
}

#private interface
sub recursive_search {
	my ($self, $attributes, $node) = @_;
	my $name = $node->{name};
	my $matchmap = $node->{match};
	my $children = $node->{children};
	my $class_stack = $self->{CLASS_STACK};
	my $node_match = 0;
	my $recurse_match = 0;
	my $generic_match = 0;

	$self->debug("testing $name");

	push(@$class_stack, $node);

	if (! defined($matchmap)) {
		#no rules for this class, so we will be a member of it only if a lower
		#rule applies
		$node_match = 1;
		$generic_match = 1;
	} elsif (ref($matchmap) ne 'HASH') {
		$self->tree_error("match was not a map");
	} else {
		if ($self->check_match($matchmap, $attributes)) {
			$node_match = 1;
		}
	}

	if ($node_match) {
		#check the children for a more specific class
		$self->debug("looking at child classes");

		if (defined($children)) {
			if (ref($children) ne 'ARRAY') {
				$self->tree_error("children must be a sequence");
			}

			foreach my $child (@$children) {
				if ($self->recursive_search($attributes, $child)) {
					$recurse_match = 1;
					last;
				}
			}
		}
	}

	if ($generic_match && ! $recurse_match) {
		#didn't match a lower level class after a generic match, so this is really no match
		pop(@$class_stack);
		return 0;
	} elsif (! $node_match) {
		pop(@$class_stack);
		return 0;
	}

	return 1;
}

#only return true if everything in $matchlist matches the stuff in $attributes
sub check_match {
	my ($self, $matchlist, $attributes) = @_;
	my $match = 0;

	#no idea why this has to be here, but with out it, matches fail
	#for very odd reasons - not sure if it's my bug or a perl bug, but it's
	#very strange
	keys(%$matchlist);

	while(my ($attribute, $regex) = each(%$matchlist)) {
		my $to_test = $attributes->{$attribute};

		if (! defined($to_test)) {
			$self->debug("nothing to test");
			return 0;
		}

		if (! defined($regex)) {
			$self->debug("no regex");
			die "regex";
		}

		if ($to_test !~ m/$regex/) {
			$self->debug("match failure");
			return 0;
		}

		$self->debug("testing data $attribute $regex '$to_test'");

		$match = 1;
	}

	if ($match) {
		$self->debug("success");

		return 1;
	}

	$self->debug("fell through with no matches");

	return 0;
}

sub tree_error {
	my ($self, $msg) = @_;
	my $class_stack = $self->{CLASS_STACK};
	my @names;

	foreach my $one (@$class_stack) {
		push(@names, $one->{name});
	}

	$self->debug("ERROR: Class tree was not consistent: $msg\n");
	$self->debug("\tClass path: ", join('::', @names), "\n");

	die "can not continue after class tree error";
}

sub debug {
	my ($self, $msg) = @_;
	print STDERR "DEBUG: $msg\n" if $self->{DEBUG};
}

1;

__END__