#!/usr/bin/perl -I../lib
use FindBin;
use lib $FindBin::Bin;
use OOPS::TestSetup qw(:slow :filter Data::Dumper Clone::PP);
use OOPS::TestCommon;
use OOPS;
require Carp::Heavy;
use Carp qw(confess);
use Scalar::Util qw(reftype);
use strict;
use warnings;
use Clone::PP qw(clone);
my $skipto = 0;
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__