package ReportGen::ObjManip;
use strict;

require Exporter;
#use Carp qw(cluck carp);

@ReportGen::ObjManip::ISA = qw ( Exporter );
# XXX: delete addObjects from below?!
@ReportGen::ObjManip::EXPORT = qw ( 
	&curLabel &clearObjects &importObjects &addObjects &objExpr
	&interpretTable &tableMedian &checkObj &getTable
	&exprDiffer &expr2str &newObj &defineObj
	&computeExpr &obj2StrByName &objVal &objBody
	&substNamesInHTML &freeText2Html
	&setWarn &getWarnObjs &label2hname &label2hlabel );
	# &raw2expr &formatVal &formatWarnVal &num2str &isNum);

use ReportGen::Globs;


my $Label;         # current default global label
my %Objs = ();     # all known objects
my %Verbs = ();    # all known verbatim objects
my %Tables = ();   # all known tables

my %Undefs = ();   # complain about indefiend symblos only once

sub curLabel {
	$Label = shift if @_;
	return $Label;
}

sub clearObjects {
	%Objs = ();
	%Tables = ();
}

sub importObjects {
	my $stats = shift;
	$Label = shift if @_;
	die("importObjects called with undefined label, stopped") unless defined $Label;

	while (my ($name, $obj) = each %{$stats}) {
		#warn("$Label\::$name");
		die($name) unless defined $obj;
		if ($obj->{atom}) {
			$Objs{"$Label\::$name"} = &newObj($name, &raw2expr($obj->{body}));
		} elsif ($obj->{verb}) {
			$Verbs{"$Label\::$name"} = $obj;
		} else {
			&interpretTable($obj);
			$Tables{"$Label\::$name"} = $obj;
			my $med = &tableMedian($obj);
			if (defined $med) {
				$name =~ s/\.hist$//;
				&defineObj("$name.median", $med);
			}
		}
	}

	addObjects();
}

sub addObjects {
	# internal objects
	&defineObj('_warn_count', 0);
	&defineObj('_have_icp_stats', &haveIcpStats());
	&defineObj('_have_cache_stats', &haveCacheStats());

	# cannot do this check: rep.rate is not defined here for some reason?
	#return unless defined &objVal('rep.rate'); # skip failed entries

	my @protos = ('');
	my @extras = ();
	push @protos, 'icp.';
	if (&objVal('_have_icp_stats')) {
		push @protos, 'icp.';
		push @extras, ('icp.rep', 'icp.hit', 'icp.miss');
		&defineObj('icp.req.size.count', 'icp.timeout.count + icp.rep.size.count');
		&defineObj('icp.timeout.ratio', '100*icp.timeout.count/icp.req.size.count');
	}

	for my $proto (@protos) {
		&defineObj("${proto}rep.ratio.obj", 100);
		&defineObj("${proto}rep.ratio.byte", 100);

		&defineObj("${proto}req.bw", "${proto}req.rate*${proto}rep.size.mean");
		&defineObj("${proto}rep.bw", "${proto}rep.rate*${proto}rep.size.mean");

		&defineObj("${proto}miss.ratio.obj", "100-${proto}hit.ratio.obj");
		&defineObj("${proto}miss.ratio.byte", "100-${proto}hit.ratio.byte");
		&defineObj("${proto}byte.rptm.mean", "${proto}rep.rptm.mean/${proto}rep.size.mean*1024");
	}

	&defineObj('uncachable.ratio.obj', "100-cachable.ratio.obj");
	&defineObj('uncachable.ratio.byte', "100-cachable.ratio.byte");
	&defineObj("conn.open.rate", "conn.open.started/duration");
	&defineObj("conn.estb.rate", "conn.estb.started/duration");

	my @obj_types = qw( fill ims.sc200 ims.sc304 basic reload 
		ims head put post abort redired_req rep_to_redir 
		hit miss cachable uncachable
		);
	# some of the objects are already defined; defineObj() should skip those
	for my $type (@obj_types) {
		&defineObj("$type.ratio.obj", "100*$type.size.count/rep.size.count");
		&defineObj("$type.ratio.byte", "100*$type.size.sum/rep.size.sum");
	}

#	for my $type (qw( hit miss ims.sc200 ims.sc304 cachable uncachable fill basic reload ims rep), @extras) {
	for my $type (@obj_types) {
		&defineObj("$type.rate", "rep.rate*$type.ratio.obj/100");
		&defineObj("$type.bw", "rep.bw*$type.ratio.byte/100");
		for my $meas (qw( min median mean max )) {
			&defineObj("$type.size.$meas");
			&defineObj("$type.rptm.$meas");
		}
	}
}

sub haveCacheStats {
	return
		&objVal('hit.rptm.count?') || 
		&objVal('hit.size.count?');
}

sub haveIcpStats {
	return
		&objVal('icp.hit.rptm.count?') || 
		&objVal('icp.miss.rptm.count?') || 
		&objVal('icp.timeout.count?');
}

sub interpretTable {
	my $obj = shift;

	my $lines = $obj->{lines};
	return unless $lines && @{$lines};
	my @lines = @{$lines};

	# guess field names using last comment line only
	my @fieldNames;
	while (@lines && $lines[0] =~ /^\#/) {	
		my $fieldNames = shift @lines;
		$fieldNames =~ s/^\#\s*//;
		@fieldNames = split(/\s+/, $fieldNames);
	}
	return unless @fieldNames;

	$obj->{columns} = {};
	for(my $c = 0; $c <= $#fieldNames; ++$c) {
		my $name = $fieldNames[$c];
		my @column;
		foreach my $line (@lines) {
			$line =~ s/^\s+//;
			push @column, (split /\s+/, $line)[$c];
		}
		$obj->{columns}->{$name} = [ @column ];
	}
}

sub tableMedian {
	my $obj = shift;
	return undef() unless $obj;

	foreach my $name (qw( count min max )) {
		return undef() unless $obj->{columns}->{$name};
	}
	my $counts = $obj->{columns}->{count};

	# find total count
	my $tot = 0;
	foreach (@{$counts}) {
		$tot += $_;
	}

	# find median
	my $sum = 0;
	for(my $c = 0; $c <= $#{$counts}; ++$c) {
		$sum += $counts->[$c];
		my $middle = ($obj->{columns}->{min}->[$c] +
			$obj->{columns}->{max}->[$c])/2;
		return $middle if $sum >= $tot/2;
	}
	return undef();
}

sub checkObj {
	my @objs = @_;
	foreach my $obj (@objs) {
		return undef() unless $obj;
		return 0 unless defined &objVal($obj);
	}
	return 1;
}

sub exprDiffer {
	my ($exp1, $exp2, $maxDiffpPtr) = @_;
	die() unless defined $maxDiffpPtr;

	my $val1 = &computeExpr($exp1);
	my $val2 = &computeExpr($exp2);

	return undef() unless defined $val1 && defined $val2;

	my $diffp = Percent($val1 - $val2, $val2);
	my $maxDiffp = ${$maxDiffpPtr};
	${$maxDiffpPtr} = $diffp;
	return abs($diffp) > $maxDiffp;
}

sub expr2str {
	my $expr = shift;
	die() unless defined $expr;

	my $res;
	{
		local $SIG{'__DIE__'};
		local $SIG{__WARN__} = sub { die $_[0] };
		$res = eval $expr;
	}
	#warn("$expr = $res");

	return undef() if $@;
	$res = "\"$res\"" if defined $res && !&isNum($res) && length($res);
	return $res;
}

sub newObj {
	my ($name, $expr) = @_;
	die($name) unless defined $name && defined $expr;
	$name = "$Label\::$name" unless $name =~ /::/;

	my $obj = {
		name => $name,
		expr => $expr,

		warn_txt    => undef(),
		warn_digest => undef(),
		warn_id     => 0,
		warn_key    => undef(),

		locked => undef(),
	};
	return $obj;
}

sub defineObj {
	my ($name, $expr) = @_;
	$name = "$Label\::$name" unless $name =~ /::/;

	return $Objs{$name} if exists $Objs{$name};

	$expr = 'undef()' unless defined $expr;
	my $obj = &newObj($name, $expr);
	$Objs{$name} = $obj;
	#warn("defined: $name as $expr");
	return $obj;
}

sub computeExpr {
	my ($expr, $objects) = @_;
	return undef() unless defined $expr;

	#warn("computeExpr: $expr");

	# split expression into a sequence of tokens
	my @tokens = ();
	my $e = $expr;
	while (length($e)) {
		if ($e =~ /^\"[^\"]*\"/) {       # quoted string
			$e = $';
			push @tokens, $&;
		}
		elsif ($e =~ /^[A-z][\w\.]*\b(?!\()/) { # object name
			$e = $';
			push @tokens, obj2StrByName($&, $expr, $objects);
		}
		elsif ($e =~ /^[A-z]\w*/) {     # perl function call?
			$e = $';
			push @tokens, $&;
		}
		elsif ($e =~ /^\$\w+/) {        # perl variable
			$e = $';
			push @tokens, $&;
		}
		elsif ($e =~ /^\d[\w\.]*/) {    # a number
			$e = $';
			push @tokens, $&;
		} else {                        # other
			push @tokens, substr($e, 0, 1);
			$e = substr($e, 1);
		}
	}
	#warn("computeExpr> ". join('', @tokens));
	return &expr2str(join('', @tokens));
}

sub obj2StrByName {
	my ($name, $expr, $objects) = @_;
	if ($name !~ /::/) {
		die($name) unless defined $Label;
		$name = "$Label\::$name";
	}

	my $obj = $Objs{$name};
	$obj = $Tables{$name} unless defined $obj;

	if (!$obj) {
		warn("warning: labeled logs have no object named `$name'\n");
		return 'undef()';
	}

	push @{$objects}, $obj if $objects;

	die("no expression defined for `$name' in `$expr'\n")
		unless defined $obj->{expr};
	die("recursion on variable `$name' in `$expr'\n")
		if $obj->{locked};

	my $val = &objVal($obj, $objects);
	#warn("obj2StrByName: $name -> $val");
	return defined $val ? $val : 'undef()';
}

sub objBody {
	my ($label) = @_;
	$label = "$Label\::$label" unless $label =~ /::/;
	return undef() unless defined $Verbs{$label};
	return $Verbs{$label}->{body};
}

sub objVal {
	my ($objORname, $objects) = @_;
	my $obj;
	my $quiet;
	if (ref($objORname)) {
		$obj = $objORname;
	} else {
		$quiet = $objORname =~ s/\?$//;
		$objORname = "$Label\::$objORname" unless $objORname =~ /::/;
		$obj = $Objs{$objORname};
	}

	if (!defined $obj) {
		warn("Object `$objORname' is not defined\n") unless 
			$objORname =~ /\_$/ || $Undefs{$objORname} || $quiet;
		$Undefs{$objORname} = 1;
		return undef();
	}

	my $oldLabel = &curLabel();
	if ($obj->{'name'} =~ /(.*?)::/) {
		&curLabel($1);
	}

	if (!exists $obj->{val}) {
		$obj->{locked} = 1;
		$obj->{val} = &computeExpr($obj->{expr}, $objects);
		$obj->{locked} = undef();
	}

	&curLabel($oldLabel);
	return $obj->{val};
}

sub objExpr {
	my ($label) = @_;
	$label = "$Label\::$label" unless $label =~ /::/;
	return undef() unless defined $Objs{$label};
	return  $Objs{$label}->{expr};
}

sub getTable {
	my $name = shift;
	$name = "$Label\::$name" unless $name =~ /::/;
	return $Tables{$name};
}

sub substNamesInHTML {
	my $html = shift;
	
	my $e = $html;
	while ($e =~ m|(?<!\\)\[([^\]]*)(?<!\\)\]|) {
		my ($left, $right, $expr) = ($`, $', $1);
		my @objs = ();
		my $fmt;
		if ($expr =~ /(?<!\\)\#(\%\S+)$/) {
			$expr = $`;
			$fmt = $1;
		}
		my $val = &computeExpr($expr, \@objs);
		$val = &formatVal($val, \@objs, $fmt);
		$e = $left . $val . $right;
	}

	$e =~ s/^\s+|\s+$//g;
	return $e;
}

sub raw2expr {
	my $raw = shift;
	return 'undef()' unless defined $raw;
	if (isNum($raw)) {
		return int($raw) == -1 ? 'undef()' : $raw;
	}
	return "\"$raw\"";
}

sub setWarn {
	my ($name, $digest, $text) = @_;
	$name = "$Label\::$name" unless $name =~ /::/;

	my $warnCount = ++$Objs{"$Label\::_warn_count"}->{'expr'};

	my $obj = $Objs{$name};
	die("$0: unknown object `$name' used in setWarn\n") unless $obj;
	die($name) unless $digest && $text;

	$obj->{warn_digest} = $digest;
	$obj->{warn_id} = $warnCount;
	$obj->{warn_key} = "warn:$warnCount";

	$obj->{warn_txt} = $text;
	$obj->{warn_txt} = &substNamesInHTML($text); # after all warn_* are set!
}

sub getWarnObjs {
	return ( 
		sort { $a->{warn_id} <=> $b->{warn_id} } 
		grep { defined $_->{warn_id} }
		values %Objs );
}

sub label2hname($) {
	my $label = shift;
	my $l = "$label\::human_name";
	my $hname = $Objs{$l} ? &objVal($l) : undef();
	$hname = $label unless defined $hname;
	$hname =~ s/^"|"$//g;
	return $hname;
}

sub label2hlabel($) {
	my $label = shift;
	my $l = "$label\::human_label";
	my $hlabel = $Objs{$l} ? &objVal($l) : undef();
	$hlabel = $label unless defined $hlabel;
	$hlabel =~ s/^"|"$//g;
	return $hlabel;
}

sub formatVal {
	my ($val, $objects, $fmt) = @_;

	return '&nbsp;' unless defined $val;

	if (defined $fmt) {
		$val = sprintf($fmt, $val);
	} elsif (isNum($val)) {
		$val = sprintf('%.2f', $val);
	} else {
		$val =~ s/^\"|\"$//g;
	}

	if ($objects && @{$objects} == 1) {
		my $obj = ${$objects}[0];
		$val = &formatWarnVal($val, $obj) if $obj->{warn_txt};
	}

	return $val;
}

sub formatWarnVal {
	my ($val, $obj) = @_;

	my $res = <<HTML;
	<font color="#FF0000"><b>
	<a style="color:#FF0000;text-decoration:none"
		onMouseOver="window.status='$obj->{warn_digest}'"
		href="#$obj->{warn_key}">$val</a>
	</b></font>
HTML

	$res =~ s/^\s+|\s*\n\s*|\s+$//g;
	return $res;
}

sub freeText2Html {
	my ($label, $li) = @_;
	$li = '<li>' unless defined $li;

	$label = "$Label\::$label" unless $label =~ /::/;

	my @lines = ();
	if (my $table = $Tables{$label}) {
		@lines = @{$table->{lines}};
	} 
	elsif (my $atomVal = &objVal($label)) {
		$atomVal =~ s/^"(.*)"$/$1/;
		push @lines, $atomVal;
	} else {
		return '';
	}

	return '' unless @lines;
	return join ('', map { "$li$_" } @lines);
}

sub num2str {
	my $num = shift;
	return sprintf('%.2f', $num);
}

sub isNum {
	my $n = shift;
	return $n =~ /^[+-]?\d+(\.\d+)?(e[+-]\d+)?$/;
}

1;