view release on metacpan or  search on metacpan

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

  new BUILDARGS unknown_fields rejected_fields from_data from_json TO_JSON to_json
  docker_attributes docker_attribute_order docker docker_extends
);

sub import {
  my ($class) = @_;
  $class->_setup_class(scalar caller);
  return;
}

# Per-class state that has to outlive the class's own compilation, because a
# generated class ends its body with `use namespace::clean`. That pragma takes
# a snapshot of the package's subs when it is reached and strips every one of
# them at the end of the class's compilation -- the imported Moo and type
# sugar, the two DSL keywords, AND anything a role composed at that point had
# already installed. Two consequences shape the setup below.
#
#   has / extends -- The runtime `docker ...;` and `docker_extends ...;` lines
#     fire after that cleanup, so by then `has` and `extends` are gone from the
#     class and `$target->can('has')` returns undef. The `docker` keyword and
#     the `Str`/`Int`/... it is handed survive the same cleanup only because
#     Perl bound their CV into the call site at compile time; a name the DSL
#     looks up by string at runtime has no such binding, so the two it resolves
#     that way are captured here while they are still imported.
#
#   the role -- API::Docker::Role::Type is NOT composed here. Composed at
#     import (a BEGIN action) its methods and its two attributes would sit in
#     namespace::clean's snapshot and be stripped with the sugar. So it is
#     composed on the first `docker`/`docker_extends` call instead -- at
#     runtime, after the cleanup, exactly as a `with 'Role'` line in a Moo
#     class body would run. Every generated class issues at least one such
#     call, and the composition lands before any object of the class is built.
my %CLASS_SUGAR;

sub _setup_class {
  my ($class, $target) = @_;
  Moo->import::into($target);
  Types::Standard->import::into($target, qw( Any Bool Int Num Str ));
  $CLASS_SUGAR{$target} = {
    has     => $target->can('has'),
    extends => $target->can('extends'),
  };
  my $stash = Package::Stash->new($target);
  $stash->add_symbol('&docker'         => sub { $class->_docker($target, @_) });
  $stash->add_symbol('&docker_extends' => sub { $class->_docker_extends($target, @_) });
  return;
}

# Compose API::Docker::Role::Type once, on the first DSL call the class makes.
# Runtime, so it outlasts the class's `use namespace::clean`; idempotent, so
# the second and later DSL calls are a cheap flag check.
sub _ensure_role {
  my ($target) = @_;
  return if $CLASS_SUGAR{$target}{role_composed};
  $CLASS_SUGAR{$target}{role_composed} = 1;
  Moo::Role->apply_roles_to_package($target, 'API::Docker::Role::Type');
  return;
}

# The one place a short class name becomes a full one. 'Mount' is
# API::Docker::Type::Mount; a name that already starts with the prefix is
# left alone; a leading + means "this is the full name, take it as it is".
# Docker's definitions are flat -- there are no groups to map, which is why
# there is no prefix table here and only this one rule.
sub _expand_class {
  my ($short) = @_;
  return substr($short, 1) if $short =~ /\A\+/;
  return $short if $short =~ /\AAPI::Docker::Type::/;
  return 'API::Docker::Type::' . $short;
}

# PortBindings <- port_bindings. One direction only; see the POD above.
sub _wire_from_perl {
  my ($name) = @_;
  return join '', map { ucfirst } split /_/, $name;
}

sub _is_type_tiny { return blessed($_[0]) && $_[0]->isa('Type::Tiny') }

# A type spec becomes a descriptor, recursively:
#   { kind => 'scalar', scalar => 'Str' }
#   { kind => 'object', class  => 'API::Docker::Type::PortBinding' }
#   { kind => 'array',  inner  => <descriptor> }
#   { kind => 'hash',   inner  => <descriptor> }   keys are caller data
#   { kind => 'any' }
# One recursive shape rather than a flag per combination, so { Str,
# ['PortBinding'] } and [[Str]] need no cases of their own anywhere.
sub _parse_type {
  my ($spec, $where) = @_;
  if (_is_type_tiny($spec)) {
    my $name = $spec->name;
    return { kind => 'any' } if $name eq 'Any';
    return { kind => 'scalar', scalar => $name } if $SCALAR_TYPE{$name};
    croak __PACKAGE__ . ": $where has unsupported type " . $name;
  }
  if (ref $spec eq 'ARRAY') {
    croak __PACKAGE__ . ": $where is an array type with "
      . scalar(@$spec) . ' element types, it needs exactly one'
      unless @$spec == 1;
    return { kind => 'array', inner => _parse_type($spec->[0], $where) };
  }
  if (ref $spec eq 'HASH') {
    my @keys = keys %$spec;
    croak __PACKAGE__ . ": $where is a hash type; write it as { Str, \$value_type }"
      unless @keys == 1 && $keys[0] eq 'Str';
    return { kind => 'hash', inner => _parse_type($spec->{Str}, $where) };
  }
  if (!ref $spec) {
    return { kind => 'any' } if $spec eq 'Any';
    return { kind => 'scalar', scalar => $spec } if $SCALAR_TYPE{$spec};
    return { kind => 'object', class => _expand_class($spec) };
  }
  croak __PACKAGE__ . ": $where has an unreadable type spec (" . ref($spec) . ')';
}


sub describe_type {
  my ($d) = @_;
  my $kind = $d->{kind};
  return lc $d->{scalar} if $kind eq 'scalar';
  return 'object<' . $d->{class} . '>' if $kind eq 'object';
  return 'array<' . describe_type($d->{inner}) . '>' if $kind eq 'array';
  return 'hash<' . describe_type($d->{inner}) . '>' if $kind eq 'hash';
  return 'any';
}

# Nothing is required, so every attribute is Maybe[...]. Hash values and
# array elements are Maybe[...] too: the daemon really does answer
# "2377/tcp": null inside a PortMap, and croaking while inflating a response
# we could otherwise use is not an improvement.
sub _isa_for {
  my ($d) = @_;
  my $kind = $d->{kind};
  return undef if $kind eq 'any';
  return $SCALAR_TYPE{ $d->{scalar} } if $kind eq 'scalar';
  return InstanceOf[ $d->{class} ] if $kind eq 'object';
  my $inner = _isa_for($d->{inner});
  return $kind eq 'array' ? ArrayRef : HashRef unless $inner;
  return $kind eq 'array' ? ArrayRef[ Maybe[$inner] ] : HashRef[ Maybe[$inner] ];
}

# The boolean normalisation, borrowed from IO::K8s::Resource (../io-k8s-p5),
# which documents the two traps: every reference is true in Perl, so \0 and a
# JSON::PP::Boolean have to be dereferenced rather than tested; and 'false'
# is a non-empty string and therefore true, so the strings are spelled out.
#
# undef stays undef rather than becoming 0. Docker tells an absent flag apart
# from a false one, TO_JSON omits undef, and "no value" must not turn into an
# explicit false on the wire.
sub _normalize_bool {
  my ($value) = @_;
  if (ref $value) {
    my $reftype = Scalar::Util::reftype($value);
    croak __PACKAGE__ . ': a Bool wants a scalar or a scalar ref, got ' . $reftype
      unless $reftype eq 'SCALAR' || $reftype eq 'REF';
    $value = $$value;
    croak __PACKAGE__ . ': a Bool scalar ref dereferenced to another reference ('
      . ref($value) . '), not a boolean' if ref $value;
  }
  return undef unless defined $value;
  return 0 if lc($value) eq 'false';
  return $value ? 1 : 0;
}

# A hashref handed to an object-typed field is inflated the way the entry
# point that started the construction reads keys: through from_data while an
# engine response is being inflated, through new otherwise. So a nested
# literal in a request a caller assembled takes both spellings, and a nested
# object in a daemon response resolves wire names only -- the same
# distinction the two entry points draw at the top level, carried one level
# down. The class is loaded on first use rather than at declaration time: the
# registry is the only place its name appears, and loading it while the
# declaring class is still compiling would close a cycle the moment two
# definitions reference each other.
sub _coerce_for {
  my ($d) = @_;
  my $kind = $d->{kind};
  return \&_normalize_bool if $kind eq 'scalar' && $d->{scalar} eq 'Bool';
  if ($kind eq 'object') {
    my $class = $d->{class};
    my $loaded;
    return sub {
      my ($value) = @_;
      return $value unless ref $value eq 'HASH';
      $loaded ||= use_module($class);
      return $API::Docker::Role::Type::RESPONSE
        ? $class->from_data($value)
        : $class->new(%$value);
    };
  }
  my $inner = $kind eq 'array' || $kind eq 'hash' ? _coerce_for($d->{inner}) : undef;
  return undef unless $inner;
  return sub {
    my ($value) = @_;
    return $value unless ref $value eq 'ARRAY';
    return [ map { $inner->($_) } @$value ];
  } if $kind eq 'array';
  return sub {
    my ($value) = @_;
    return $value unless ref $value eq 'HASH';
    # The keys are the caller's data: copied across, never touched.
    return { map { ($_ => $inner->($value->{$_})) } keys %$value };
  };
}

# The serialisation half of a descriptor. Called by
# API::Docker::Role::Type::TO_JSON, which decides what to skip.
sub _encode_value {
  my ($d, $value) = @_;
  return undef unless defined $value;
  my $kind = $d->{kind};
  if ($kind eq 'scalar') {
    my $scalar = $d->{scalar};
    return $value ? JSON::MaybeXS::true() : JSON::MaybeXS::false() if $scalar eq 'Bool';
    return int($value) if $scalar eq 'Int';
    return 0 + $value  if $scalar eq 'Num';
    return "$value";
  }
  return $value->TO_JSON if $kind eq 'object';
  return [ map { _encode_value($d->{inner}, $_) } @$value ] if $kind eq 'array';
  return { map { ($_ => _encode_value($d->{inner}, $value->{$_})) } keys %$value }
    if $kind eq 'hash';
  return [ @$value ] if ref $value eq 'ARRAY';
  return { %$value } if ref $value eq 'HASH';
  return $value;
}