The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl -w

use strict;

use Test::More tests => 1;

# test an Object 3 levels deep (Patient->Visit->Test)

use Array::To::Moose qw (:ALL);

eval 'use VarianReportsMoose qw(print_obj)';

use Data::Dumper;

use Carp;

#------------
package Test;
use Moose;
use MooseX::StrictConstructor;
use namespace::autoclean;

has 'name'        => (is => 'rw', isa => 'Str');
has 'result'      => (is => 'rw', isa => 'Num');

#------------
package Visit;
use Moose;
use MooseX::StrictConstructor;
use namespace::autoclean;

has 'date'     => (is => 'rw', isa => 'Str'            );
has 'md'       => (is => 'rw', isa => 'Str'            );
has 'Tests'    => (is => 'rw', isa => 'ArrayRef[Test]' );

#------------
package Patient;
use Moose;
use MooseX::StrictConstructor;
use namespace::autoclean;

has 'last'        => (is => 'rw', isa => 'Str'            );
has 'first'       => (is => 'rw', isa => 'Str'            );
has 'Visits'      => (is => 'rw', isa => 'ArrayRef[Visit]' );

Test   ->meta->make_immutable;
Visit  ->meta->make_immutable;
Patient->meta->make_immutable;

package main;

#   patient  |    visit    |   test
# last  first|visit_date md|name result
# 0     1     2          3  4    5    <- column index

package main;

sub Npat { Patient->new(last => $_[0], first => $_[1], Visits => $_[2] ) }
sub Nvis {   Visit->new(date => $_[0], md    => $_[1], Tests => $_[2]  ) }
sub Ntst {    Test->new(name => $_[0], result => $_[1]                 ) }

# patients
my @p1 = ( "Smith", "John"  );
my @p2 = ( "Smith", "Alex"  );
my @p3 = ( "Green", "Helen" );

#visits
my @v1 = ( "03/10/2008", "F Jones, M.D." );
my @v2 = ( "08/17/2008", "F Jones, M.D." );

my @v3 = ( "11/28/2008", "L Ho, D.D.S"   );

my @v4 = ( "07/18/2010", "A. Black M.D." );
my @v5 = ( "12/12/2010", "A. Black M.D." );
my @v6 = ( "02/14/2011", "L Ho, D.D.S."  );

#tests
my @t1 = ( "test1", 1.1 );
my @t2 = ( "test2", 2.1 );
my @t3 = ( "test3", 3.1 );
my @t4 = ( "test4", 4.1 );
my @t5 = ( "test5", 5.1 );
my @t6 = ( "test6", 6.1 );
my @t7 = ( "test7", 7.1 );
my @t8 = ( "test8", 8.1 );
my @t9 = ( "test9", 9.1 );

my $data = [
              # p1
              [ @p1, @v1, @t1 ],
              [ @p1, @v1, @t2 ],
              [ @p1, @v1, @t3 ],

              [ @p1, @v2, @t4 ],
              [ @p1, @v2, @t5 ],

              # p2
              [ @p2, @v3, @t5 ],
              [ @p2, @v3, @t6 ],
              [ @p2, @v3, @t7 ],

              # p3
              [ @p3, @v4, @t1 ],
              [ @p3, @v4, @t2 ],
              [ @p3, @v4, @t3 ],

              [ @p3, @v5, @t4 ],
              [ @p3, @v5, @t5 ],
              [ @p3, @v5, @t6 ],
              [ @p3, @v5, @t7 ],

              [ @p3, @v6, @t8 ],
              [ @p3, @v6, @t9 ],
];

my $expected = [
    Npat(@p1, [ Nvis( @v1, [ Ntst(@t1),
                             Ntst(@t2),
                             Ntst(@t3),
                           ]
                    ),

                Nvis( @v2, [ Ntst(@t4),
                             Ntst(@t5)
                           ]
                     ),
              ]
        ),

    Npat(@p2, [ Nvis( @v3, [ Ntst(@t5),
                             Ntst(@t6),
                             Ntst(@t7)
                           ]
                    ),
              ]
        ),

    Npat(@p3, [ Nvis(@v4, [ Ntst(@t1),
                            Ntst(@t2),
                            Ntst(@t3)
                          ]
                    ),
                Nvis(@v5, [ Ntst(@t4),
                            Ntst(@t5),
                            Ntst(@t6),
                            Ntst(@t7)
                          ]
                    ),
                Nvis(@v6, [ Ntst(@t8),
                            Ntst(@t9)
                          ]
                    )
              ]
        ),
];


# <-    patient    -> <-  visit  -> <- test  ->
# patient_id name age md visit_date name result
# 0          1    2   3  4          5    6      <- column index

my $object = array_to_moose(
                        data => $data,
                        desc => {
                          class => 'Patient',
                          last  => 0,
                          first => 1,
                          Visits => {
                            class => 'Visit',
                            date  => 2,
                            md    => 3,
                            Tests => {
                              class  => 'Test',
                              name   => 4,
                              result => 5,
                            } # tests
                          } # visits
                        } # patients
);

#print "Object:\n", print_obj($object);
#print "Expected:\n", print_obj($expected);

is_deeply($expected, $object, "obj with an ArrayRef sub-obj");