view release on metacpan or  search on metacpan

t/1.t  view on Meta::CPAN

#!perl -w

use strict;

use Test::More;

# basic testing of internal function _check_descriptor(), including
# set_class_ind() (but not set_key_ind() as that requires constructing
# RefHash['] objects. (See 3a.t for set_key_ind() testing)
#
# Also test attributes with names "class" & "key" stuff, including when class
# & key are redefined
# also test set_key_ind(), set_class_ind() with values not an identifier

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

BEGIN {
  eval "use Test::Exception";
  plan skip_all => "Test::Exception needed" if $@;
}

plan tests => 37;


my $n1 = [ 1, 1, 1 ];
my $n2 = [ 2, 2, 2 ];
my $n3 = [ 3, 3, 3 ];
my $n4 = [ 4, 4, 4 ];

my $data = [ $n1, $n2, $n3, $n4 ];

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

has [ qw( last first gender ) ] => (is => 'rw', isa => 'Str');

__PACKAGE__->meta->make_immutable;

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

extends 'Person';

has 'aliases' => (is => 'ro', isa => 'ArrayRef[Str]');

__PACKAGE__->meta->make_immutable;

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

extends 'Person';

has 'Visits' => (is => 'ro', isa => 'ArrayRef[Visit]');

__PACKAGE__->meta->make_immutable;

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

extends 'Person_w_Visit';

has 'aliases' => (is => 'ro', isa => 'ArrayRef[Str]');

__PACKAGE__->meta->make_immutable;

package main;

my ($class, $attrib, $rattrib, $sub_obj_desc);

#
# call errors
#

# simple object, no ref-attributes, no sub-objects,
my $desc = {
  class => 'Person',
  last  => 0,
  gender => 2,
};

# check returned values for simple object
lives_ok {
   ($class, $attrib, $rattrib, $sub_obj_desc) = _check_descriptor($data, $desc)
         } '_check_descriptor(Person) OK';

is($class, 'Person', "_check_descriptor()  returns class Person OK");

is_deeply($attrib, { 'last', 0, 'gender', 2 },
    "_check_descriptor(Person)  returns \$attrib OK");

is(@$rattrib, 0, "_check_descriptor() no ref attributes in Person OK");

ok(keys %$sub_obj_desc == 0, "_check_descriptor() no subobj in Person OK");

# object with ref attributes
$desc = {
  class   => 'Person_w_Aliases',
  last    => 0,
  first   => 1,
  aliases => [2],
};

lives_ok {
  ($class, $attrib, $rattrib, $sub_obj_desc) = _check_descriptor($data, $desc);
         } '_check_descriptor(Person_w_Alias) OK';

is($class, 'Person_w_Aliases',
              "_check_descriptor()  returns class Person_w_Alias OK");

is_deeply($attrib, { 'last', 0, 'first', 1 },
    "_check_descriptor(Person_w_Aliases)  returns \$attrib OK");

is_deeply($rattrib, { 'aliases', 2 },
    "_check_descriptor(Person_w_Aliases)  returns \$rattrib OK");

ok(keys %$sub_obj_desc == 0,
                "_check_descriptor() no subobj in Person_w_Alias");

# object with a sub-object
my $subdesc = {
  class => 'Visit',
  date  => 3,