The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl

use Test::More;
use File::Basename;
use lib File::Basename::dirname(__FILE__)."/../../../lib";
use lib File::Basename::dirname(__FILE__)."/../..";
use URT; 
use URT::ObjWithHash;
use strict;
use warnings;

plan tests => 27;

my $o = URT::ObjWithHash->create(myhash1 => { aaa => 111, bbb => 222 }, mylist => [ ccc => 333, ddd => 444 ]); 
my @h = ($o->myhash1, $o->mylist); 
#diag "data was: " . Data::Dumper::Dumper($o,@h);
is(ref($h[0]),'HASH', "got a hashref back");
is(ref($h[1]),'ARRAY', "got an arrayref back");
is_deeply($h[0],{ aaa => 111, bbb => 222 },"got correct values back for hashref");

#TODO: {
#    local $TODO = 'array seems to be out of order';
    
    is_deeply($h[1],[ ccc => 333, ddd => 444 ],"got correct values back for arrayref");
#};

# make sure things being associated with objects
# are not being copied in the constructor

class TestClassB {
    has   => [
        value => { is => 'String' },
    ],
};

class TestClassA {
    has   => [
        b_thing => { is => 'TestClassB' }
    ],
};

my $ax = TestClassA->create();
ok($ax, "Created TestClassA without b_thing");

my $bx = TestClassB->create( value => 'abcdfeg' );
ok($bx, "Created TestClassB with value");

ok($ax->b_thing($bx), "Set b_thing to TestClassB object");
is($ax->b_thing, $bx, "b_thing is TestClassB object");

my $ay = TestClassA->create(
    b_thing => $bx
);
ok($ay, "Created TestClassA with bx as b_thing");
is($ax->b_thing,$ay->b_thing, "ax->b_thing is ay->b_thing");

ok($bx->value('oyoyoy'), "Changed bx->value");
is($ax->b_thing->value, $ay->b_thing->value, "ax->b_thing value is ay->b_thing value");

my $by = TestClassB->create( value => 'zzzykk' );
ok($by, "Created TestClassB with value");

ok($ay->b_thing($by), "Changed ay b_thing to by");

isnt($ax->b_thing,$ay->b_thing,"ax b_thing is not ay b_thing");
isnt($ax->b_thing->value,$ay->b_thing->value,"ax->b_thing value is not ay->b_thing value");

class TestClassC {
    has => [ 
        foo => { is => 'ARRAY' }
    ]
};

my $c;
ok($c = TestClassC->create,"Created TestClassC with no properties");
ok($c->foo([qw{foo bar baz}]),"Set foo");
is_deeply($c->foo,[qw{foo bar baz}],'Checking array');

ok($c = TestClassC->create(
    foo => [qw{foo bar baz}]
),"Created TestClassC with foo arrayref");
is_deeply($c->foo,[qw{foo bar baz}],'Checking array for alpha-sort');

#TODO: {
#    local $TODO = 'somewhere, somehow PAP workflow does this....  so lets make sure it works';
    
    my $d;
    ok(eval { $d = TestClassC->create(
        foo => [
            $c,  ## first element is a ur object
            [  ## next is a psuedo hash, or something that looks like one
                { make => 1, perl => 2, mad => 3, at => 4, us => 5 },
                'this',
                'is',
                'a',
                'pseudo',
                'hash' 
            ]
        ]
    ) }, "created TestClassC with psuedo-hash like array");
#    diag "data was: " . Data::Dumper::Dumper($d);
#}

# make Bar a real class so it is not mistaken for a primitive
package Bar;
sub bar {};
package main;

# new rule logic seems to allow boolexpr references to be cloned
for my $c ('Bar') {
    class Foo { 
        has => [ 
            a => { is => $c }, 
            b => { is => $c }, 
            c => { is => $c }
        ] 
    }; 

    my @r = map { bless({ id => $_ },$c); } (100..102); 
    my @f = qw/a b c/;

    my $oo = Foo->define_boolexpr(a => $r[0], c => $r[2], b => $r[1]); 
    my %pp = $oo->params_list; 
    my @pp = @pp{@f}; 

    my $o = $oo->normalize; 
    my %p = $o->params_list; 
    my @p = @p{@f}; 

    my $str = Data::Dumper::Dumper(\@r,\%pp,\%p,$oo,$o); 
    is("@pp", "@r", "unnormalized rule decomposes correctly") or diag $str;
    is("@p",  "@r", "normalized rule decomposes correctly") or diag $str;
}



my @p = (
          'myhash1',
          {
            'bbb' => 222,
            'aaa' => 111
          },
          'mylist',
          [
            'ccc',
            333,
            'ddd',
            444
          ],
          'id',
          'linus43.gsc.wustl.edu 21757 1286150139 10001',
          'id',
          'linus43.gsc.wustl.edu 21757 1286150139 10001',
          'id',
          'linus43.gsc.wustl.edu 21757 1286150139 10001',
);
my $b = URT::ObjWithHash->define_boolexpr(@p);
my $hu = $b->value_for('myhash1');
my $au = $b->value_for('mylist');

note($hu);
note($au);
my $n = $b->normalize;
my $hn = $n->value_for('myhash1');
my $an = $n->value_for('mylist');

is($an,$au,"the normalized array is the same ref as the unnormalized");
is($hn,$hu,"the normalized array is the same ref as the unnormalized");

my %b = $b->params_list;
my %n = $n->params_list;
my @b = %b;
my @n = %n;
is("@n","@b", "normalization keeps references correct");