API-Docker

 view release on metacpan or  search on metacpan

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

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

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

    unless defined $name && $name =~ /\A[a-z][a-z0-9_]*\z/;
  croak __PACKAGE__ . ": '$name' in $target is a name this role already uses"
    if $RESERVED{$name};
  croak __PACKAGE__ . ": '$name' is declared twice in $target"
    if $REGISTRY{$target} && $REGISTRY{$target}{$name};

  my $wire     = delete $opt{wire} // _wire_from_perl($name);
  # The Perl-name guard above has a twin: _docker_wire_index maps a wire name
  # to one Perl name, so a second field claiming a wire name would make the
  # first unreachable on inflation while TO_JSON wrote both to that one key.
  # None of the 201 generated classes does this; the generator could emit it
  # the day a hand-picked `wire` collides with a derived one (karr k85).
  if (my ($taken) = sort grep { $REGISTRY{$target}{$_}{wire} eq $wire }
                      keys %{ $REGISTRY{$target} || {} }) {
    croak __PACKAGE__ . ": '$name' in $target asks for the wire name "
      . "'$wire', which '$taken' already has";
  }
  my $since    = delete $opt{since};
  my $enum     = delete $opt{enum};
  my $required = delete $opt{required} ? 1 : 0;
  croak __PACKAGE__ . ": '$name' in $target got unknown option(s): "
    . join(', ', sort keys %opt) if %opt;

  my $descriptor = _parse_type($type_spec, "$target\::$name");
  my $isa    = _isa_for($descriptor);
  my $coerce = _coerce_for($descriptor);
  $REGISTRY{$target}{$name} = {
    name     => $name,
    wire     => $wire,
    type     => $descriptor,
    since    => $since,
    enum     => $enum,
    required => $required,
    # The same two the Moo attribute below is given, kept so the response
    # path can ask whether a value fits before handing it to the constructor
    # rather than finding out by being croaked at (karr k83).
    isa      => $isa ? Maybe[$isa] : undef,
    coerce   => $coerce,
  };
  {
    no strict 'refs';
    push @{"${target}::_docker_attr_order"}, $name;
  }
  API::Docker::Role::Type::_invalidate_docker_cache($target);

  my $has = $CLASS_SUGAR{$target}{has} // $target->can('has');
  my $info = $REGISTRY{$target}{$name};
  $has->($name,
    is => 'rw',
    ($info->{isa}    ? (isa    => $info->{isa})    : ()),
    ($info->{coerce} ? (coerce => $info->{coerce}) : ()),
  );
  return;
}

sub _docker_extends {
  my ($class, $target, @parents) = @_;
  _ensure_role($target);
  croak __PACKAGE__ . ": docker_extends in $target needs at least one class"
    unless @parents;
  my @full = map { use_module(_expand_class($_)) } @parents;
  my $extends = $CLASS_SUGAR{$target}{extends} // $target->can('extends');
  $extends->(@full);
  API::Docker::Role::Type::_invalidate_docker_cache($target);
  return;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

API::Docker::Type - The DSL and attribute registry behind the generated Docker types

=head1 VERSION

version 0.004

=head1 SYNOPSIS

    package API::Docker::Type::Mount;
    use API::Docker::Type;

    docker target => Str;

    =attr target

    Container path.

    =cut

    docker bind_options => 'Mount::BindOptions', since => '1.41';
    docker labels       => { Str, Str };
    docker ulimits      => [ 'Resources::Ulimit' ];
    docker cpu_shares   => Int, wire => 'CPUShares';

=head1 DESCRIPTION

C<API::Docker::Type> is imported, never inherited. Importing it pulls
L<Moo>, the type vocabulary and L<API::Docker::Role::Type> into the calling
package and installs two keywords, C<docker> and C<docker_extends>.

Every class under C<API::Docker::Type::*> is a Perl mirror of one entry
under C<definitions:> in Docker's swagger, which is checked into C<spec/>.
The classes are written from that specification and B<not> from a running
daemon; C<maint/spec-drift-check.pl> is what keeps that claim true.

=head2 What C<docker> does

    docker $perl_name => $type;
    docker $perl_name => $type, wire => 'CPUShares';
    docker $perl_name => $type, since => '1.44';
    docker $perl_name => $type, required => 1;

It declares a Moo attribute B<and> writes an entry into a package-level
registry. Both halves matter: the attribute is what a caller uses, the

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

    use API::Docker::Type;

    docker_extends 'Resources';

C<allOf> in swagger means composition, and Perl inheritance says exactly
that. Nothing is duplicated: the parent's fields, their POD and the inline
classes declared inside the parent all stay in one place, and the merged
registry in L<API::Docker::Role::Type> presents C<HostConfig> with all ~70
fields. The alternative -- copying the parent's declarations into the child
-- would duplicate 31 attributes and their C<=attr> blocks and force the
inline classes underneath them to be named twice.

An C<allOf> holding a single C<$ref> and nothing else is not composition at
all; it is swagger's way of hanging a description on a C<$ref>
(C<Mount.Type> and C<MountPoint.Type> both do it). Such a field takes the
type of what it references, which for C<MountType> is C<Str>.

=head2 Inline objects become classes

A property whose schema is an object with its own C<properties>, or an array
whose C<items> are such an object, becomes a class named after the
definition that declares it:

    Mount.BindOptions             -> API::Docker::Type::Mount::BindOptions
    Mount.VolumeOptions.DriverConfig
                                  -> API::Docker::Type::Mount::VolumeOptions::DriverConfig
    Resources.Ulimits[]           -> API::Docker::Type::Resources::Ulimit

The last one is the exception to the mechanical rule: an array of inline
objects is named for one element, and turning C<Ulimits> into C<Ulimit> is a
judgement call, not a derivation. Those names live in
C<maint/spec-drift-exceptions.yaml> so the checker and a generator agree on
them.

=head2 A generated class loads what it references

Each class carries a plain C<use> for every other type class it names, so
loading C<API::Docker::Type::HostConfig> brings its whole subtree with it.
The declaration itself does B<not> load anything: a class named in a
C<docker> line is loaded lazily, on the first hashref that has to be
inflated into it. That is deliberate belt and braces -- v1.51's definitions
happen to have no reference cycles, and if a later version grows one the
C<use> for the back edge is what a generator has to leave out, while the
model keeps working either way.

=head1 THE TYPE VOCABULARY

    Str  Int  Num  Bool       scalars
    Any                       untyped; passed through as it arrived
    [Str]                     an array of scalars
    [[Str]]                   an array of arrays of scalars
    ['PortBinding']           an array of typed objects
    'PortBinding'             a single typed object
    '+Some::Other::Class'     the same, without the namespace prefix
    { Str, Str }              a hash whose KEYS ARE CALLER DATA
    { Str, ['PortBinding'] }  the same, with typed values

A bare class name is short: C<'PortBinding'> is
C<API::Docker::Type::PortBinding>, C<'Mount::BindOptions'> is
C<API::Docker::Type::Mount::BindOptions>. The expansion happens in
C<_expand_class> and nowhere else; a leading C<+> escapes it.

=head2 describe_type

    API::Docker::Type::describe_type($info->{type});   # 'hash<array<object>>'

A descriptor as one string, for the drift checker's report. Objects render
as C<< object<Class> >>.

=head1 SUPPORT

=head2 Issues

Please report bugs and feature requests on GitHub at
L<https://github.com/Getty/p5-api-docker/issues>.

=head1 CONTRIBUTING

Contributions are welcome! Please fork the repository and submit a pull request.

=head1 AUTHOR

Torsten Raudssus <getty@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2026 by Torsten Raudssus <torsten@raudssus.de> L<https://raudssus.de/>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut