#!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,
};
$desc = { class  => 'Person_w_Visit',
          last   => 0,
          gender => 2,
          Visits => $subdesc,
};

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

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

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

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

is_deeply($sub_obj_desc, { 'Visits' => $subdesc },
      "_check_descriptor() Person_w_Visit \$sub_obj_desc OK");

# object with ref attrib and a sub-object 
$desc = {
  class   => 'Person_w_Aliases_n_Visit',
  last    => 0,
  first   => 1,
  aliases => [2],
  Visits => $subdesc,
};

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

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

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

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

is_deeply($sub_obj_desc, { 'Visits' => $subdesc },
      "_check_descriptor() Person_w_Aliases_n_Visit \$sub_obj_desc OK");


# "class => ..." and "key => ..." tests

throws_ok {
  _check_descriptor($data, { last => 0, gender => 2 });
         } qr/No class descriptor 'class =>/,
           '_check_attributes() No Class';

throws_ok {
  _check_descriptor($data, { class => '', last => 0, gender => 2 });
         } qr/No class descriptor 'class =>/,
           '_check_descriptor() empty Class';

# check that when we redefine the 'class' keyword it shows up in the error
# messages
set_class_ind('_klass');

lives_ok {
   _check_descriptor($data, { _klass => 'Person', last  => 0, gender => 2 })
         } "_check_descriptor(Person) set 'class' indicator to '_klass'";

throws_ok {
  _check_descriptor($data, { last => 0, gender => 2 });
         } qr/No class descriptor '_klass =>/,
           '_check_attributes() No _klass OK';

# set it back to default
set_class_ind();

lives_ok {
   _check_descriptor($data, { class => 'Person', last  => 0, gender => 2 })
         } "_check_descriptor(Person) reset 'class' indicator";

# end testing of set_class_ind()

throws_ok {
  _check_descriptor($data, {
                          # no 'class'
                          last => 0, gender => 2
                        }
                );
         } qr/No class descriptor 'class =>/,
           "_check_attributes() reset class ind to default: 'No class' OK";

throws_ok {
  _check_descriptor($data, { class => 'ePrson', last => 0, gender => 2 });
         } qr/Class 'ePrson' not defined/,
           '_check_descriptor() Class undefined';

throws_ok {
  _check_descriptor($data, { class => 'Person', name => 0, gender => 2 });
         } qr/Attribute 'name' not in 'Person' object/,
           '_check_descriptor() wrong attribute name';

# construct two classes with attrib 'class' and 'CLASS'
package Obj_Attr_class;
use namespace::autoclean;
use Moose;

has [ qw( name class ) ] => (is => 'rw', isa => 'Str');

__PACKAGE__->meta->make_immutable;

package Obj_Attr_CLASS;
use namespace::autoclean;
use Moose;

has [ qw( name CLASS ) ] => (is => 'rw', isa => 'Str');

__PACKAGE__->meta->make_immutable;

package main;

throws_ok {
  _check_descriptor($data,{ class => 'Obj_Attr_class', name => 0 })
          } qr/The 'Obj_Attr_class' object has an attribute called 'class'/,
            "_check_descriptor() object with attribute called 'class'";

# fix this with set_class_ind()
set_class_ind('CLASS');

lives_ok {
  _check_descriptor($data,{ CLASS => 'Obj_Attr_class', name => 0 })
         }
          "object with attribute called 'class' - fixed with set_class_ind()";

# but now this will fail
throws_ok {
  _check_descriptor($data,{ class => 'Obj_Attr_class', name => 0 })
          } qr/No class descriptor 'CLASS =>/,
            "_check_descriptor() no class when 'class' changed to 'CLASS'";

# and this too
throws_ok {
  _check_descriptor($data,{ CLASS => 'Obj_Attr_CLASS', name => 0 })
          } qr/The 'Obj_Attr_CLASS' object has an attribute called 'CLASS'/,
            "_check_descriptor() object with attribute called 'CLASS'";

# reset the class indicator
set_class_ind();

# construct two classes with attribs 'key' and 'KEY'
package Obj_Attr_key;
use namespace::autoclean;
use Moose;

has [ qw( name key ) ] => (is => 'rw', isa => 'Str');

__PACKAGE__->meta->make_immutable;

package Obj_Attr_KEY;
use namespace::autoclean;
use Moose;

has [ qw( name KEY ) ] => (is => 'rw', isa => 'Str');

__PACKAGE__->meta->make_immutable;

package main;

throws_ok {
  _check_descriptor($data,
      { class => 'Obj_Attr_key', name => 0, key => 2 })
          } qr/The 'Obj_Attr_key' object has an attribute called 'key'/,
            "_check_descriptor() object with attribute called 'key'";

# fix by setting key indicator
set_key_ind('KEY');

lives_ok {
  _check_descriptor($data, { class => 'Obj_Attr_key', name => 0, key => 2 })
         } "object with attribute called 'key' - fixed with set_key_ind()";

# key => ... isn't required, so can't do the same tests as with class => ...
# without constructing an object and testing if its the correct HashRef[']
# (tested somewhere else?)

# but we can do this test
throws_ok {
  _check_descriptor($data,
      { class => 'Obj_Attr_KEY', name => 0, KEY => 2 })
          } qr/The 'Obj_Attr_KEY' object has an attribute called 'KEY'/,
            "_check_descriptor() object with attribute called 'KEY'";

# check that set_class_ind() and set_key_ind() do the right thing with bad args
throws_ok {
  set_class_ind(' ')
          } qr/set_class_ind\(' '\) not a legal identifier/,
          "set_class_ind() not a legal identifier";

throws_ok {
  set_key_ind(' ')
          } qr/set_key_ind\(' '\) not a legal identifier/,
          "set_key_ind() not a legal identifier";