#!perl -w
use strict;
use Test::More;
# Test mismatches in sub-objects between the declaration of the object in
# Moose, vs. that in "desc"
#
# (We use code from a previous example, 4c.t,
# which had an Object with ArrayRef[], HashRef[] and non-ref sub-objects)
use Array::To::Moose qw (:ALL);
BEGIN {
eval "use Test::Exception";
plan skip_all => "Test::Exception needed" if $@;
}
plan tests => 6;
eval 'use VarianReportsMoose qw(print_obj)';
use Data::Dumper;
use Carp;
# for error testing
package NotaVisit;
use Moose;
use MooseX::StrictConstructor;
has date => (is => 'ro', isa => 'Str');
has doctor => (is => 'ro', isa => 'Str');
has diagnosis => (is => 'ro', isa => 'Str');
package Visit;
use Moose;
use MooseX::StrictConstructor;
has date => (is => 'ro', isa => 'Str');
has doctor => (is => 'ro', isa => 'Str');
has diagnosis => (is => 'ro', isa => 'Str');
package Patient;
use Moose;
use MooseX::StrictConstructor;
has last => (is => 'ro', isa => 'Str' );
has first => (is => 'ro', isa => 'Str' );
has FirstVisit => (is => 'ro', isa => 'Visit' );
has Visits => (is => 'ro', isa => 'ArrayRef[Visit]');
has HVisits => (is => 'ro', isa => 'HashRef[Visit]' );
no Moose;
package main;
sub Npat { Patient->new(last => $_[0], first => $_[1], FirstVisit => $_[2],
Visits => $_[3], HVisits => $_[4] ) }
sub Nvis { Visit->new(date => $_[0], doctor => $_[1], diagnosis => $_[2] ) }
sub NvisH {
$_[0] => Visit->new(date => $_[0], doctor => $_[1], diagnosis => $_[2] )
}
# patients
my @p1 = ( "Smith", "John" );
my @p2 = ( "Smith", "Alex" );
my @p3 = ( "Green", "Helen" );
#visits
my @v1 = ( "03/10/2008", "F Jones, M.D.", "Tendonitis" );
my @v2 = ( "08/17/2008", "F Jones, M.D.", "Tinea Pedis" );
my @v3 = ( "11/28/2008", "L Ho, D.D.S", "Toothache" );
my @v4 = ( "07/18/2010", "A. Black M.D.", "RSI" );
my @v5 = ( "12/12/2010", "A. Black M.D.", "Allergies" );
my @v6 = ( "02/14/2011", "L Ho, D.D.S.", "Caries" );
my $data = [
[ @p1, @v1 ],
[ @p1, @v2],
[ @p2, @v3 ],
[ @p3, @v4 ],
[ @p3, @v5 ],
[ @p3, @v6 ],
];
my $expected = [
Npat(@p1, Nvis(@v1), [ Nvis(@v1), Nvis(@v2) ],
{ NvisH(@v1), NvisH(@v2) } ),
Npat(@p2, Nvis(@v3), [ Nvis(@v3) ],
{ NvisH(@v3) } ),
Npat(@p3, Nvis(@v4), [ Nvis(@v4), Nvis(@v5), Nvis(@v6) ],
{ NvisH(@v4), NvisH(@v5), NvisH(@v6) } ),
];
#
# rows of @$data contain: Last, First, Date, Doctor, Diagnosis
# at positions: [0] [1] [2] [3] [4]
#
my $object = array_to_moose(
data => $data,
desc => {
class => 'Patient',
last => 0,
first => 1,
FirstVisit => {
class => 'Visit',
date => 2,
doctor => 3,
diagnosis => 4,
},
Visits => {
class => 'Visit',
date => 2,
doctor => 3,
diagnosis => 4,
},
HVisits => {
class => 'Visit',
key => 2,
date => 2,
doctor => 3,
diagnosis => 4,
},
}
);
#print "Object:\n", print_obj($object);
#print "Expected:\n", print_obj($expected);
# leave this here to check we haven't mucked up the data
is_deeply($expected, $object,
"obj with ArrayRef HashRef, & single-ref sub-objs (to check code)");
# Moose says HVisits are HashRef[Visit], but if we leave out the "key => ..."
# attribute, atm() will return it as an Arrayref[`]
throws_ok { array_to_moose( data => $data,
desc => {
class => 'Patient',
last => 0,
first => 1,
HVisits => {
class => 'Visit',
# key => 2,
date => 2,
doctor => 3,
diagnosis => 4,
},
}
);
} qr/Moose attribute .* has type 'HashRef.*ARRAY/,
"Moose says HashRef[`], desc says ArrayRef[`]";
# Moose says Visits are ArrayRef[Visit], but if we put in a "key => ..."
# attribute, atm() will return it as an Hashref[`]
throws_ok { array_to_moose( data => $data,
desc => {
class => 'Patient',
last => 0,
first => 1,
Visits => {
class => 'Visit',
key => 2, # <- key
date => 2,
doctor => 3,
diagnosis => 4,
},
}
);
} qr/Moose attribute .* has type 'ArrayRef.*HASH/,
"Moose says ArrayRef[`], desc says HashRef[`]";
# Moose says HVisits are HashRef[Visit], but desc
# says 'HashRef[NotaVisit]'
throws_ok { array_to_moose( data => $data,
desc => {
class => 'Patient',
last => 0,
first => 1,
HVisits => {
class => 'NotaVisit',
key => 2,
date => 2,
doctor => 3,
diagnosis => 4,
},
}
);
}
qr/Moose attribute .* has type 'HashRef\[Visit\].*HashRef\[NotaVisit\]/,
"Moose says HashRef[Visit], desc says HashRef[NotaVisit]";
# Moose says Visits are ArrayRef[Visit], but desc
# says 'ArrayRef[NotaVisit]'
throws_ok { array_to_moose( data => $data,
desc => {
class => 'Patient',
last => 0,
first => 1,
Visits => {
class => 'NotaVisit',
date => 2,
doctor => 3,
diagnosis => 4,
},
}
);
}
qr/Moose attribute .* has type 'ArrayRef\[Visit\].*ArrayRef\[NotaVisit\]/,
"Moose says ArrayRef[Visit] desc says ArrayRef[NotaVisit]";
# Moose says FirstVisits are type Visit, but desc says type NotaVisit
throws_ok { array_to_moose( data => $data,
desc => {
class => 'Patient',
last => 0,
first => 1,
FirstVisit => {
class => 'NotaVisit',
date => 2,
doctor => 3,
diagnosis => 4,
},
}
);
} qr/Moose attribute 'FirstVisit' has type 'Visit'.*'NotaVisit'/s,
"Moose says type is 'Visit' desc says 'NotaVisit'";
#print Dumper($object);