view release on metacpan or  search on metacpan

lib/Array/To/Moose.pm  view on Meta::CPAN

# $class,      the class name,
# $attribs,    hashref (name => column_index) of "simple" attributes
# $ref_attribs hashref (name => column_index) of attribs which are
#               ArrayRef[']s of simple types (i.e. not a Class)
#               (HashRef[']s not implemented)
# $sub_desc    hashref (name => desc) of sub-object descriptors
############################################
sub _check_descriptor {
  my ($data, $desc) = @_;

  # remove from production!
  croak "_check_descriptor() needs two arguments"
    unless @_ == 2;

  my $class = $desc->{$CLASS}
    or croak "No class descriptor '$CLASS => ...' in descriptor:\n",
       Dumper($desc);

  my $meta;

  # see other example of getting meta in Moose::Manual::???
  eval{ $meta = $class->meta };
  croak "Class '$class' not defined: $@"
    if $@;

  my $ncols = @{ $data->[0] };

  # separate out simple (i.e. non-reference) attributes, reference
  # attributes, and sub-objects
  my ($attrib, $ref_attrib, $sub_desc);

  while ( my ($name, $value) =  each %$desc) {

    # check lines which have 'simple' column numbers ( attrib or key => N)
    unless (ref($value) or $name eq $CLASS) {

      my $msg = "attribute '$name => $value'";

      croak "$msg must be a (non-negative) integer"
        unless $value =~ /^\d+$/;

      croak "$msg greater than # cols in the data ($ncols)"
        if $value > $ncols - 1;
    }

    # check to see if there are attributes called 'class' or 'key'
    if ($name eq $CLASS or $name eq $KEY) {
      croak "The '$class' object has an attribute called '$name'"
        if $meta->find_attribute_by_name($name);

      next;
    }

    croak "Attribute '$name' not in '$class' object"
      unless $meta->find_attribute_by_name($name);

    if ((my $ref = ref($value)) eq 'HASH') {
      $sub_desc->{$name} = $value;

    } elsif ($ref eq 'ARRAY') {
      # descr entry looks like, e.g.:
      #   attrib => [6],
      #
      # ( or attrib => [key => 6, value => 7],  in future... ?)

      croak "attribute must be of form, e.g.: '$name => [N], "
            . "where N is a single integer'"
          unless @$value == 1;

      my $msg = "attribute '$name => [ " . $value->[0] . " ]'. '" .
                  $value->[0] . "'";

      croak "$msg must be a (non-negative) integer"
        unless $value->[0]  =~ /^\d+$/;

      croak "$msg greater than # cols in the data ($ncols)"
        if $value->[0] > $ncols - 1;

      $ref_attrib->{$name} = $value->[0];

    } elsif ($ref) {
      croak "attribute '$name' can't be a '$ref' reference";

    } else {
      # "simple" attribute
      $attrib->{$name} = $value;
    }
  }


  # check ref- and ...
  _check_ref_attribs($class, $ref_attrib)
    if $ref_attrib;

  # ... non-ref attributes from the descriptor against the Moose object
  _check_non_ref_attribs($class, $attrib)
    if $attrib;

  croak "no attributes with column numbers in descriptor:\n", Dumper($desc)
    unless $attrib and %$attrib;

  return ($class, $attrib, $ref_attrib, $sub_desc);
}

########################################
# Usage: $sub_obj = _check_subobj($class, $attr_name, $type, $sub_obj);
#
# $class        is the name of the current class
# $attr_name    is the name of the attribute in the descriptor, e.g.
#               MyObjs => { ... } (used only diagnostic messages)
# $type         is the expected Moose type of the sub-object
#               i.e. 'HashRef[MyObj]', 'ArrayRef[MyObj]', or 'MyObj'
# $sub_obj_ref  Reference to the data (just returned from a recursive call to
#               array_to_moose() ) to be stored in the sub-object,
#               i.e. isa => 'HashRef[MyObj]', isa => 'ArrayRef[MyObj]',
#               or isa => 'MyObj'
#
#
# Checks that the data in $sub_obj_ref agrees with the type of the object to
# contain it
# if $type is a ref to an object (isa => 'MyObj'), _check_subobj() converts