view release on metacpan or  search on metacpan

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

}


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;
}

sub _docker_attr_order {
  my $class = ref($_[0]) || $_[0];
  return $ORDER_CACHE{$class} //= _merge_order($class);
}

sub _merge_order {
  my ($class) = @_;
  my (@order, %seen);
  _append_order($class, \@order, \%seen);
  return \@order;
}

sub _append_order {
  my ($class, $order, $seen) = @_;
  no strict 'refs';
  # Parents first: the swagger lists the inherited `$ref` ahead of the
  # class's own properties, and this keeps TO_JSON in that order.
  _append_order($_, $order, $seen) for @{"${class}::ISA"};
  for my $attr (@{"${class}::_docker_attr_order"}) {
    next if $seen->{$attr}++;
    push @$order, $attr;
  }
  return;
}

sub _docker_wire_index {
  my $class = ref($_[0]) || $_[0];
  return $WIRE_CACHE{$class} //= do {
    my $reg = _docker_attr_registry($class);
    +{ map { ($reg->{$_}{wire} => $_) } keys %$reg };
  };
}

# Called by API::Docker::Type after every registration: a merged view
# computed before a parent gained an attribute must not survive.
sub _invalidate_docker_cache {
  my ($class) = @_;
  my %sweep;
  @sweep{ keys %ATTR_CACHE, keys %ORDER_CACHE, keys %WIRE_CACHE,
          keys %ENTITY_CACHE } = ();
  for my $cached (keys %sweep) {
    next unless $cached eq $class || $cached->isa($class);
    delete $ATTR_CACHE{$cached};
    delete $ORDER_CACHE{$cached};
    delete $WIRE_CACHE{$cached};
    delete $ENTITY_CACHE{$cached};
  }
  delete $ATTR_CACHE{$class};
  delete $ORDER_CACHE{$class};
  delete $WIRE_CACHE{$class};
  delete $ENTITY_CACHE{$class};
  return;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

API::Docker::Role::Type - Instance behaviour of a generated API::Docker::Type class

=head1 VERSION

version 0.004

=head1 SYNOPSIS

    # composed automatically by `use API::Docker::Type;`
    my $hc = API::Docker::Type::HostConfig->from_data($from_the_daemon);
    my $wire = $hc->TO_JSON;            # CamelCase keys, JSON booleans
    my $bytes = $hc->to_json;

=head1 DESCRIPTION

Every class under C<API::Docker::Type::*> composes this role; it is applied
by L<API::Docker::Type>'s C<import>, so a generated class never names it.

The role reads the attribute registry L<API::Docker::Type> writes -- it never
walks the object's own keys. A field that is an attribute but not in the
registry is invisible here, which is exactly what
C<maint/spec-drift-check.pl> exists to catch.

=head2 The two entry points have different jobs

L</from_data> inflates an engine B<response>: its keys are the daemon's, so
only the registry's wire names are read and everything else is preserved
under the name it arrived with. L</new> assembles a B<request> out of what a
caller wrote: its keys are the caller's, so the Perl spelling is read first
and the wire spelling is an alias for it.