package Yaala::Data::Core;

use strict;
use warnings;
#use vars qw#$DATA#;

=head1 Yaala::Data::Core

Store data to the internal structure and retrieve it again.

=cut

use Exporter;
use Yaala::Data::Setup qw#$USED_FIELDS $USED_AGGREGATIONS $SELECTS#;
use Yaala::Data::Convert qw#convert#;
use Yaala::Data::Persistent qw#init#;

@Yaala::Data::Core::EXPORT_OK = qw#receive store get_values#;
@Yaala::Data::Core::ISA = ('Exporter');

# holds all data
#our $DATA = {};
our $DATA = init ('$DATA', 'hash');

# holds the order of all fields stored in $DATA
our @FIELD_ORDER = ();

# holds all values for each field (key)
our $VALUES_PER_FIELD = init ('$VALUES_PER_FIELD', 'hash');

# sort fields by occurence count in the config file.
# This _might_ speed things up.
@FIELD_ORDER = (sort { $USED_FIELDS->{$b} <=> $USED_FIELDS->{$a} } (keys %$USED_FIELDS));

my $VERSION = '$Id: Core.pm,v 1.13 2003/12/09 09:12:05 octo Exp $';
print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);

if ($::DEBUG)
{
	require Data::Dumper;
	import Data::Dumper qw#Dumper#;
}

return (1);

=head1 Routines

=head2 Yaala::Data::Core::delete_fields (\%data)

Removes uninteresting fields from the hash-ref

=cut
sub delete_fields
{
	my $data = shift;

	foreach my $key (keys %$data)
	{
		unless (defined ($USED_FIELDS->{$key})
					or defined ($USED_AGGREGATIONS->{$key}))
		{
			delete ($data->{$key});
		}
	}
}

=head2 Yaala::Data::Core:receive ($sel, $agg, \%query)

query data from the internal structure. Takes care of wildcards (missing
keys in the query hash) itself..

=cut
sub receive
{
	my $sel = shift;
	my $agg = shift;
	my $query = shift;
	my $retval = 0;
	my $sel_string = $sel->[3];

	if (ref ($agg))
	{
		print STDERR $/, "Bug: ", join (', ', caller ());
	}

	if (!defined ($DATA->{$sel_string}{$agg}))
	{
		print STDERR $/, __FILE__, ": Unavailable aggregation requested: ``$agg''. Returning 0.";
		
		if ($::DEBUG)
		{
			my $dump = Data::Dumper->Dump ([$sel, $query], [qw#$sel $query#]);
			my $file = __FILE__ . ': ';
			$dump =~ s/^/$file/gm;
			$dump =~ s/[\n\r]+$//s;
			print STDERR $/, $dump;
		}
		
		return (0);
	}

	my $ptr = $DATA->{$sel_string}{$agg};

	if ($::DEBUG & 0x80)
	{
		my $dump = Data::Dumper->Dump ([$query], ['$query']);
		my $tmp = __FILE__ . ': ';
		$dump =~ s/^/$tmp/gm;
		$dump =~ s/[\n\r]+$//g;
		print STDERR $/, $dump;
	}

	for (@{$sel->[1]})
	{
		my $fld = $_;
		if (defined ($query->{$fld}))
		{
			if (defined ($ptr->{$query->{$fld}}))
			{
				$ptr = $ptr->{$query->{$fld}};
			}
			else
			{
				print STDERR $/, __FILE__, ': Unavailable field requested. Returning 0.'
				if ($::DEBUG & 0x10);
				return (0);
			}
		}
		else
		{
			my $sum = 0;
			my @val = keys (%{$VALUES_PER_FIELD->{$sel_string}{$fld}});
			print STDERR $/, __FILE__, ': Query not unique. Performing subqueries for ',
			scalar (@val), " values of field '$fld'." if ($::DEBUG & 0x10);
			for (@val)
			{
				my $val = $_;
				my %new_query = %$query;
				$new_query{$fld} = $val;
				$sum += receive ($sel, $agg, \%new_query);
			}
			print $/, __FILE__, ": Returning, \$sum = $sum" if ($::DEBUG & 0x10);
			return ($sum);
		}
	}
	print $/, __FILE__, ": Returning, \$\$ptr = $$ptr" if ($::DEBUG & 0x10);
	return ($$ptr);
}

=head2 Yaala::Data::Core:store (\%data)

Saves data in the internal structure.

=cut
sub store
{
	my $data = shift;
	
	delete_fields ($data);

	if ($::DEBUG & 0x80)
	{
		my $dump = Data::Dumper->Dump ([$data, $DATA], [qw#$data $DATA#]);
		my $file = __FILE__ . ': ';
		$dump =~ s/^/$file/gm;
		$dump =~ s/[\n\r]+$//s;
		print STDERR $/, $dump;
	}
	
	for (@$SELECTS)
	{
		my $sel = $_;
		my $agg = $sel->[0];
		my $sel_string = $sel->[3];
		my $ptr;
		my $total_fields = 0;
		my $i = 0;

		if (check_where_clauses ($sel, $data))
		{
			next;
		}
		
		for (@{$sel->[0]})
		{
			my $agg = $_;
		
			if (!defined $DATA->{$sel_string}{$agg}) { $DATA->{$sel_string}{$agg} = {}; }
			my $ptr = $DATA->{$sel_string}{$agg};
	
			print STDERR $/, __FILE__, ": \$DATA->{$sel_string}{$agg}" if ($::DEBUG & 0x10);
			
			$total_fields = scalar (@{$sel->[1]});
			for ($i = 0; $i < $total_fields; $i++)
			{
				my $fld = $sel->[1][$i];
	
				my $field_value = convert ($fld, $data->{$fld});
				print STDERR '{', $field_value, '}' if ($::DEBUG & 0x10);
	
				if (!defined ($ptr->{$field_value}))
				{
					if ($i == ($total_fields - 1))
					{
						my $tmp = 0;
						$ptr->{$field_value} = \$tmp;
					}
					else
					{
						$ptr->{$field_value} = {};
					}
				}
				
				$ptr = $ptr->{$field_value};
				
				$VALUES_PER_FIELD->{$sel_string}{$fld}{$field_value}++;
			}
			print STDERR " += ", $data->{$agg} if ($::DEBUG & 0x10);
	
			if (!defined ($$ptr) or !defined ($data->{$agg}))
			{
				print STDERR $/, __FILE__, ': ',
				Data::Dumper->Dump ([$sel, $data], [qw/sel data/]);
			}
			
			$$ptr += $data->{$agg};
		}
	}
}

sub get_values
{
	my $sel = shift;
	my $sel_string = $sel->[3];
	my $field = shift;

	if (!defined ($VALUES_PER_FIELD->{$sel_string}))
	{
		print STDERR $/, __FILE__, ': selection not defined in $VALUES_PER_FIELD.' if ($::DEBUG);
		return ();
	}
	
	my @vals = keys (%{$VALUES_PER_FIELD->{$sel_string}{$field}});

	return (@vals);
}

sub check_where_clauses
# true  == reject
# false == accept
{
	my $sel = shift;
	my $data = shift;

	for (@{$sel->[2]})
	{
		my $where = $_;
		my ($key, $op, $val) = @$where;
		my $data_val; 

		if (!defined ($data->{$key}) and 
			($op ne '!=' and
				$op ne '!~' and
				$op ne '<=' and
				$op ne '<'))
		{
			print STDERR $/, __FILE__, ": \$data->{$key} not defined." if ($::DEBUG);
			return (1);
		}
		elsif (!defined ($data->{$key}) and 
			($op eq '!=' or
				$op eq '!~' or
				$op eq '<=' or
				$op eq '<'))
		{
			next;
		}

		$data_val = $data->{$key};

		if ($op eq '=~')
		{
			if ($data_val =~ qr/$val/)
			{
				next;
			}
			else
			{
				return (1);
			}
		}
		elsif ($op eq '!~')
		{
			if ($data_val !~ qr/$val/)
			{
				next;
			}
			else
			{
				return (1);
			}
		}
		else
		{
			my $retval = 0;
			my $eval = qq#if (\$data_val $op \$val) { \$retval = 0; } else { \$retval = 1; }#;
			eval "$eval";
			die ('eval: ' . $@) if ($@);

			return (1) if ($retval);
		}
	}

	return (0);
}
