view release on metacpan or  search on metacpan

lib/Data/Domain.pm  view on Meta::CPAN

  my $msg     = $self->inspect($data, $context);
  
  # return the validated data tree if there is no error message
  return $context->{gather_valid_data} if !$msg;

  # otherwise, die with the error message
  croak $self->name . ": invalid data because " . $self->stringify_msg($msg);
}


sub stringify_msg {
  my ($self, $msg) = @_;

  return does($msg, 'ARRAY') ? join ", ", map {$self->stringify_msg($_)} grep {$_} @$msg
       : does($msg, 'HASH')  ? join ", ", map {"$_:" . $self->stringify_msg($msg->{$_})} grep {$msg->{$_}} sort keys %$msg
       :                       $msg;
}



sub func_signature {
  my ($self) = @_;

  # this method is overridden in List() and Struct() for dealing with arrays and hashes
  return sub {my $params = $self->validate(@_); $params};
}


sub meth_signature {
  my ($self) = @_;
  my $sig = $self->func_signature;

  # same as func_signature, but the first param is set apart since it is the invocant of the method
  return sub {my $obj = shift; return ($obj, &$sig)};          # note: &$sig is equivalent to $sig->(@_)
}




#----------------------------------------------------------------------
# METHODS FOR INTERNAL USE
#----------------------------------------------------------------------
# Note : methods without initial underscore could possibly be useful for subclasses, either through
# invocation or through subclassing. Methods with initial underscore are really internal mechanics;
# I doubt that anybody else would want to invoke or subclass them ... but nothing prevents you from
# doing so !



sub msg {
  my ($self, $msg_id, @args) = @_;
  my $msgs     = $self->{-messages};
  my $name     = $self->name;

  # if using a coderef, these args will be passed to it
  my @msgs_call_args = ($name, $msg_id, @args);
  shift @msgs_call_args if $USE_OLD_MSG_API; # because older versions did not pass the $name arg

  # perl v5.22 and above warns if there are too many @args for sprintf.
  # The line below prevents that warning
  no if $] ge '5.022000', warnings => 'redundant';

  # if there is a user-defined message, return it
  if (defined $msgs) { 
    for (ref $msgs) {
      /^CODE/ and return $msgs->(@msgs_call_args);                # user function
      /^$/    and return "$name: $msgs";                          # user constant string
      /^HASH/ and do { if (my $msg_string =  $msgs->{$msg_id}) {  # user hash of msgs
                         return sprintf "$name: $msg_string", @args;
                       }
                       else {
                         last; # not found in this hash - revert to $GLOBAL_MSGS below
                       }
                     };
      # otherwise
      croak "-messages option should be a coderef, a hashref or a sprintf string";
    }
  }

  # there was no user-defined message, so use global messages
  if (ref $GLOBAL_MSGS eq 'CODE') {
    return $GLOBAL_MSGS->(@msgs_call_args);
  }
  else {
    my $msg_entry = $GLOBAL_MSGS->{$self->subclass}{$msg_id}
                  || $GLOBAL_MSGS->{Generic}{$msg_id}
     or croak "no error string for message $msg_id";
    return ref $msg_entry eq 'CODE' ? $msg_entry->(@msgs_call_args)
                                    : sprintf "$name: $msg_entry", @args;
  }
}


sub name { 
  my ($self) = @_;
  return $self->{-name} || $self->subclass;
}


sub subclass { # returns the class name without initial 'Data::Domain::'
  my ($self) = @_;
  my $class = ref($self) || $self;
  (my $subclass = $class) =~ s/^Data::Domain:://;
  return $subclass;
}


sub _initial_inspect_context {
  my ($self, $data, %extra) = @_;

  return {root       => $data,
          flat       => {},
          path       => [],
          list       => [],
          %extra,
        };
}


sub _check_has {
  my ($self, $data, $context) = @_;