#!/usr/bin/perl -I../lib -I./..


BEGIN {
	if ($ENV{HARNESS_ACTIVE} && ! $ENV{OOPSTEST_SLOW}) {
		print "1..0 # Skipped: run this by hand or set \$ENV{OOPSTEST_SLOW}\n";
		exit;
	}

	$OOPS::SelfFilter::defeat = 0
		unless defined $OOPS::SelfFilter::defeat;

	for my $m (qw(Data::Dumper Clone::PP)) {
		unless ( eval " require $m " ) {
			print "1..0 # Skipped: this test requires the $m module\n";
			exit;
		}
		$m->import();
	}
}

use OOPS;
require Carp::Heavy;
use Carp qw(confess);
use Scalar::Util qw(reftype);
use strict;
use warnings;

use OOPS::TestCommon;

import Clone::PP qw(clone);

my $skipto = 0;

modern_data_compare();
print "1..245574\n";
my $debug2 = 1;
my $debug3 = 0;

resetall; # --------------------------------------------------
{
	my $realdebug = $debug;
	my $failures = <<'END';
END
	#
	# flags:
	#
	#	V - try with virtual object and regular object
	#	h - set $key to various keys a hash might use
	#	a - set $key to various index an array might use
	#	v - replace $pval with potential values
	#
	my $tests = <<'END';

		- my $zz = 7

		- @{$root->{akey}} = ()

		- pop(@{$root->{akey}})

		- unshift(@{$root->{akey}});

		V- $root = {}

		V- $root = []

		V- $root = 7

		Vh- delete $root->{$key}

		a- splice(@{$root->{akey}}, $key, 4)

		v- push(@{$root->{akey}}, $pval);

		v- unshift(@{$root->{akey}}, $pval);

		v- ${$root->{rkey1}} = $pval;

		v- ${$root->{rkey2}} = $pval;

		v- ${$root->{rkey3}} = $pval;

		v- ${$root->{rkey4}} = $pval;

		Vhv- $root->{$key} = $pval

		Vhv- my $x = $pval; $root->{$key} = \$x

		av- $root->{akey}[$key] = $pval

END
	my %failures;
	for my $failure (split(/\n/, $failures)) {
		$failure =~ s/^\s+//;
		$failure =~ s/\s+$//;
		$failures{$failure} = 1;
		print "# adding '$failure'\n" if $debug2;
	}
	for my $test (split(/^\s*$/m, $tests)) {
		$test =~ s/\s*(\S*)-\s//s;
		my $flag = $1;

		my (@virt) = $flag =~ /V/
			? (qw(
				0 
				virtual
			))
			: (0);
		my (@key) = (0);

		if ($flag =~ /h/) {
			@key = (qw(
				'okey'
				'udkey'
				'akey'
				'hkey'
				'0'
				''
				'skey'
				'newkey'
				'rkey1'
				'rkey2'
				'rkey3'
				'eskey'
				'0key'
				undef
			));
		} elsif ($flag =~ /a/) {
			@key = (3, 0, 1, 2, 4..10);
		} 


		no warnings qw(syntax);
		my (@val) = $flag =~ /v/
			? (qw( 
				{} 
				getref(%$root,'udkey')
				\$root->{akey}[3]
				getref(%$root,'okey')
				getref(%{$root->{hkey}},'skey2')
				$root
				''
				'0'
				'12'
				undef
				'xyz' 
				[] 
				['a','b',7] 
				{x=>1,y=>'z'} 
				$root->{akey}
				$root->{skey}
				$root->{hkey} 
				$root->{rkey} 
				$root->{okey} 
				scalar("abcd"x($ocut/4+1)) 
				\'rval2'
				\[7,8,9]
				\{n=>'m'}
			))
#XXX						\$z
			: ( '1' );
		use warnings;

		my @skips = (qw(10 00 01 11));
		my @groups = ('onegroup', '', 'manygroups');

		my $nodata_per_loop = count(grep(! /root/, @val)) / scalar(@val);
		my $skippre_per_loop = count(grep(substr($_, 0, 1), @skips)) / scalar(@skips);
		my $skippost_per_loop = 2 * count(grep(substr($_, 1, 1), @skips)) / scalar(@skips);
		my $loops = scalar(@val) * scalar(@key) * scalar(@groups) * scalar(@virt) * scalar(@skips);
		my $base_per_loop = 
			3					# resetall
			+ 2 * 2					# rcon
			+ (($flag =~ /V/) ? 1 : 0)		# test vobj
			+ 1					# test unconditional
			+ 1					# notied
			;
		my $per_loop = $base_per_loop + $skippre_per_loop + $skippost_per_loop;
		my $expected = $okay + $loops * ($per_loop + $nodata_per_loop);
		print "# $test\n";
		printf "# per_loop = %d ( 9 + flag:%s + pre:%s + post:%s + nodata:%s : expected = %s)\n",
			$per_loop,  
			(($flag =~ /V/) ? 1 : 0),
			$skippre_per_loop,
			$skippost_per_loop,
			$nodata_per_loop,
			$expected;
		if ($expected < $skipto) {
			$okay = $expected;
			next;
		}

		for my $val (@val) {
			$nodata_per_loop = ($val =~ /root/) ? 0 : 1;
			my $loops = scalar(@key) * scalar(@groups) * scalar(@virt) * scalar(@skips);
			my $expected2 = $okay + $loops * ($per_loop + $nodata_per_loop);
			if ($expected2 < $skipto) {
				$okay = $expected2;
				next;
			}

			for my $key (@key) {
				my $loops = scalar(@groups) * scalar(@virt) * scalar(@skips);
				my $expected3 = $okay + $loops * ($per_loop + $nodata_per_loop);
				if ($expected3 < $skipto) {
					$okay = $expected3;
					next;
				}

				my $sub; 
				my $e = <<END;
					\$sub = sub { 
						my \$z = 'ov09'x($ocut/4+1);
						my \$root = shift; 
						my \$pval = $val;
						my \$key = $key;
						no warnings;
						$test
					}
END

				eval $e;
				die "on $test/$val/$key ... $e ... $@" if $@;

				for my $skips (@skips) {
					my $skippre = substr($skips, 0, 1);
					my $skippost = substr($skips, 1, 1);

					my $loops = scalar(@groups) * scalar(@virt);
					my $per_loop2 = $base_per_loop + $nodata_per_loop
						+ ($skippre ? 0 : 1)
						+ ($skippost ? 0 : 2);
					my $expected4 = $okay + $loops * $per_loop2;
					if ($expected4 < $skipto) {
						$okay = $expected4;
						next;
					}

					for my $groupmangle (@groups) {

						my $loops = scalar(@virt);
						my $expected5 = $okay + $loops * $per_loop2;
						if ($expected5 < $skipto) {
							$okay = $expected5;
							next;
						}

						for my $vobj (@virt) {

							my $expected6 = $okay + $per_loop2;
							if ($expected6 < $skipto) {
								$okay = $expected6;
								next;
							}
							my $preok = $okay;

							resetall;

							die if $debug && $okay != $preok + 3;

							my $desc = "$flag- $test: key=$key val=$val V$vobj.S$skippre$skippost.G$groupmangle";
							$desc =~ s/\A\s*(.*?)\s*\Z/$1/s;
							$desc =~ s/\n\s*/\\n /g;
							$debug = $failures{$desc}
								? 0
								: $realdebug;
							print "# desc='$desc' debug=$debug\n";

							print "# $desc\n" if $debug;

							my $rv = 'rval';
							my $x = 'ov09'x($ocut/4+1);
							my $mroot = {
								# the length of this array should match the flag =~ /a/ array size of @key (above).
								akey => [ '0', undef, 'a12', 19, [], {}, \'r9', scalar('ov02'x($ocut/4+1)), scalar('ov04'x($ocut/4+1)), [1,2,3] ],
								hkey => { skey2 => 'sval2' },
								skey => 'sval',
								okey => 'over' x ($ocut/4 + 1),
								rkey1 => \$rv,
								rkey2 => \[4,5,6],
								rkey3 => \{z=>'q'},
#								rkey4 => \ (scalar('ov01'x($ocut/4+1))),
#XXX								rkey4 => \$x,
								eskey => '',
								udkey => undef,
								'0key' => '0',
							};

							$r1->{named_objects}{root} = clone($mroot);
							$r1->virtual_object($r1->{named_objects}{root}, $vobj) if $vobj;
							$r1->commit;
							nocon;
							if ($groupmangle) {
								groupmangle($groupmangle);
							}
							rcon;
							die if $debug && $okay != $preok + 3 + 2;

							print "#PROGRESS: BEFORE $desc\n" if $debug2;

							my $proot = $r1->{named_objects}{root};

							test(docompare($mroot, $proot), $desc) unless $skippre;

							die if $debug && $okay != $preok + 3 + 2 + ($skippre ? 0 : 1);

							print "mroot before: ".Dumper($mroot)."\n" if $debug3;

							&$sub($mroot);

							print "mroot after: ".Dumper($mroot)."\n" if $debug3;
							print "#PROGRESS: PRE CHANGES: $desc\n" if $debug2;
							print "proot before: ".Dumper($proot)."\n" if $debug3;

							print "# EXECUTING: $desc\n" if $debug;

							&$sub($proot);

							print "#PROGRESS: POST CHANGES: $desc\n" if $debug2;
							print "proot after: ".Dumper($proot)."\n" if $debug3;
							print "#PROGRESS: PRE COMPARE: $desc\n" if $debug2;

							test(docompare($mroot, $proot), $desc) unless $skippost;

							die if $debug && $okay != $preok + 3 + 2 + ($skippre ? 0 : 1) + ($skippost ? 0 : 1);

							print "#PROGRESS: POST COMPARE, PRE COMMIT: $desc\n" if $debug2;

							$r1->commit;

							print "#PROGRESS: POST COMMIT, PRE COMPARE#2: $desc\n" if $debug2;

							test(docompare($mroot, $proot), $desc) unless $skippost;

							die if $debug && $okay != $preok + 3 + 2 + ($skippre ? 0 : 1) + ($skippost ? 0 : 2);

							print "#PROGRESS: POST COMPARE#2, PRE RECONNECT: $desc\n" if $debug2;

							undef $proot;
							rcon;
# our $xy = 1;
							die if $debug && $okay != $preok + 3 + 2 + ($skippre ? 0 : 1) + ($skippost ? 0 : 2) + 2;

							my $qroot = $r1->{named_objects}{root};

							print "#PROGRESS: POST RECONNECT, PRE COMPARE #3: $desc\n" if $debug2;

							test(docompare($mroot, $qroot), $desc);
							die if $debug && $okay != $preok + 3 + 2 + ($skippre ? 0 : 1) + ($skippost ? 0 : 2) + 2 +1;

							print "#PROGRESS: POST COMPARE #3, PRE DELETES: $desc\n" if $debug2;

							test(!$vobj == !$r1->virtual_object($qroot), $desc) if $flag =~ /V/;
							die if $debug && $okay != $preok + 3 + 2 + ($skippre ? 0 : 1) + ($skippost ? 0 : 2) + 2 + 1 + (($flag =~ /V/) ? 1 : 0);

							nukevar($qroot, $mroot);
							delete $r1->{named_objects}{root};

							print "#PROGRESS: POST DELETES, PRE COMMIT: $desc\n" if $debug2;

							$r1->commit;

							print "#PROGRESS: FINAL COMMIT DONE: $desc\n" if $debug2;

							undef $qroot;
							nocon;

							nodata unless $val =~ /root/;
							die if $debug && $okay != $preok + 3 + 2 + ($skippre ? 0 : 1) + ($skippost ? 0 : 2) + 2 + 1 + ($flag =~ /V/ ? 1 : 0) + (($val =~ /root/) ? 0 : 1);
							notied($desc);
							die if $debug && $okay != $preok + 3 + 2 + ($skippre ? 0 : 1) + ($skippost ? 0 : 2) + 2 + 1 + ($flag =~ /V/ ? 1 : 0) + (($val =~ /root/) ? 0 : 1) + 1;

							print "#PROGRESS: DONE WITH TEST: $desc\n" if $debug2;

							print "# okay: $okay expected6: $expected6\n";
							die "bad prediction" if $debug && $okay != $expected6;
						}
						print "# okay: $okay expected5: $expected5\n";
						die "bad prediction" if $debug && $okay != $expected5;
					}
					print "# okay: $okay expected4: $expected4\n";
					die "bad prediction" if $debug && $okay != $expected4;
				}
				print "# okay: $okay expected3: $expected3\n";
				die "bad prediction" if $debug && $okay != $expected3;
			}
			print "# okay: $okay expected2: $expected2\n";
			die "bad prediction" if $debug && $okay != $expected2;
			check_resources();
		}
		print "# okay: $okay expected: $expected\n";
		die "bad prediction" if $debug && $okay != $expected;

	}
	$debug = $realdebug;
}

resetall; # --------------------------------------------------
print "# ---------------------------- done ---------------------------\n" if $debug;
$okay--;
print "# tests: $okay\n" if $debug;

exit 0; # ----------------------------------------------------

sub count
{
	return scalar(@_);
}

1;

__END__
