view release on metacpan or  search on metacpan

lib/API/Docker/Role/Type.pm  view on Meta::CPAN

  my %args;
  my %unknown  = %{ $data->{unknown_fields}  || {} };
  my %rejected = %{ $data->{rejected_fields} || {} };
  # In effect for the coercions _fits runs below as well as for the
  # constructor at the end: a nested hashref is part of the same response
  # and has to be read as one.
  local $RESPONSE = 1;
  for my $key (keys %$data) {
    next if $key eq 'unknown_fields' || $key eq 'rejected_fields';
    my $attr = $wire->{$key};
    # A decoded response is a map of wire names and nothing else, so a key
    # that is not one is a field we have not heard of -- even where it spells
    # an entity attribute such as `client`. Those never come from the daemon:
    # the resource API injects them as the %extra above, kept apart from $data
    # on purpose, so a key of that name in the response cannot overwrite ours
    # and is forwarded verbatim like any other unknown field (karr k104).
    unless (defined $attr) {
      $unknown{$key} = $data->{$key};
      next;
    }
    my ($fits, $value) = _fits($reg->{$attr}, $data->{$key});
    if ($fits) { $args{$attr} = $value; next }
    # A value the model cannot use costs that one field, not the response it
    # arrived in. It is kept under its wire name exactly as an unknown field
    # is, and named in rejected_fields so the caller can tell it apart from a
    # field the engine never sent (karr k83).
    $unknown{$key}  = $data->{$key};
    $rejected{$key} = $attr;
  }
  # Resolved to Perl names already, so the BUILDARGS above is a no-op over
  # them and stays idempotent across the two passes the `allOf` shape makes.
  return $class->new(%args, %extra,
    unknown_fields  => \%unknown,
    rejected_fields => \%rejected,
  );
}

# Does a value an engine sent fit the attribute the wire name resolved to?
# Answers with the coerced value where it does. The coercion runs here rather
# than being left to the constructor because it is what turns a nested
# hashref into an object and what refuses a Bool that is neither -- both have
# to happen before the value can be judged at all. Every coercion the DSL
# builds is idempotent, so the constructor running it again on the result
# changes nothing.
#
# The leniency is this sub and its one caller. `new` never comes through
# here, so a caller who writes a value the swagger does not allow is still
# croaked at by Moo: that is a typo in a request, not an engine being itself.
sub _fits {
  my ($info, $value) = @_;
  local $@;
  my $coerced = $info->{coerce} ? eval { $info->{coerce}->($value) } : $value;
  return (0) if $@;
  return (0) if $info->{isa} && !$info->{isa}->check($coerced);
  return (1, $coerced);
}


sub from_json {
  my ($class, $json) = @_;
  return $class->from_data(JSON::MaybeXS->new(utf8 => 1)->decode($json));
}


sub TO_JSON {
  my ($self) = @_;
  my %out = %{ $self->unknown_fields };
  my $reg = $self->_docker_attr_registry;
  for my $attr (@{ $self->_docker_attr_order }) {
    my $value = $self->$attr;
    next unless defined $value;
    $out{ $reg->{$attr}{wire} }
      = API::Docker::Type::_encode_value($reg->{$attr}{type}, $value);
  }
  return \%out;
}


sub to_json {
  my ($self) = @_;
  return JSON::MaybeXS->new(utf8 => 1, canonical => 1, convert_blessed => 1)
    ->encode($self->TO_JSON);
}


sub docker_attributes { return $_[0]->_docker_attr_registry }


sub docker_attribute_order { return $_[0]->_docker_attr_order }

# --- attributes that are not the daemon's ----------------------------------
#
# API::Docker::Role::Entity puts `client` on a generated class so the
# convenience methods have something to delegate through. It arrives at the
# same constructor as the daemon's fields, and without being named here it is
# neither a registry entry nor a wire name, so BUILDARGS would file it under
# unknown_fields -- where TO_JSON would faithfully offer the client object to
# the engine and JSON::MaybeXS would die trying to encode it. A class that
# composes such a role answers _entity_attributes with their names.

sub _entity_attribute_index {
  my $class = ref($_[0]) || $_[0];
  return $ENTITY_CACHE{$class} //= do {
    my %mine = $class->can('_entity_attributes')
      ? (map { ($_ => 1) } $class->_entity_attributes)
      : ();
    my $reg  = _docker_attr_registry($class);
    my $wire = _docker_wire_index($class);
    # Both sets reach the same constructor, so a name in both is an ambiguity
    # nobody can resolve at runtime -- say so instead of picking one.
    for my $name (sort keys %mine) {
      croak __PACKAGE__ . ": $class has '$name' as an entity attribute and as "
        . 'a daemon field; one of the two has to be renamed'
        if $reg->{$name} || defined $wire->{$name};
    }
    \%mine;
  };
}

# --- merged views over @ISA ------------------------------------------------
#
# A generated class that resolves an `allOf` inherits its parent's fields
# (see API::Docker::Type), so every lookup below is the class's own registry
# entry merged with its ancestors'. Nearest declaration wins.

sub _docker_attr_registry {
  my $class = ref($_[0]) || $_[0];
  return $ATTR_CACHE{$class} //= _merge_registry($class);
}

sub _merge_registry {
  my ($class) = @_;
  my %info = %{ $API::Docker::Type::REGISTRY{$class} // {} };
  no strict 'refs';
  for my $parent (@{"${class}::ISA"}) {
    my $up = _merge_registry($parent);
    $info{$_} //= $up->{$_} for keys %$up;
  }
  return \%info;
}