API-Docker
view release on metacpan or search on metacpan
requires 'Moo';
requires 'JSON::MaybeXS';
requires 'MIME::Base64';
requires 'IO::Socket::UNIX';
requires 'URI';
requires 'namespace::clean';
requires 'Log::Any';
on test => sub {
requires 'Test::More';
requires 'Path::Tiny';
};
lib/API/Docker.pm view on Meta::CPAN
use API::Docker::API::System;
use API::Docker::API::Containers;
use API::Docker::API::Images;
use API::Docker::API::Networks;
use API::Docker::API::Volumes;
use API::Docker::API::Exec;
has host => (
is => 'ro',
default => sub { $ENV{DOCKER_HOST} // 'unix:///var/run/docker.sock' },
);
has api_version => (
is => 'rwp',
default => undef,
);
has tls => (
is => 'ro',
default => 0,
);
has cert_path => (
is => 'ro',
default => sub { $ENV{DOCKER_CERT_PATH} },
);
has _version_negotiated => (
is => 'rw',
default => 0,
);
with 'API::Docker::Role::HTTP';
has system => (
is => 'lazy',
builder => sub { API::Docker::API::System->new(client => $_[0]) },
);
has containers => (
is => 'lazy',
builder => sub { API::Docker::API::Containers->new(client => $_[0]) },
);
has images => (
is => 'lazy',
builder => sub { API::Docker::API::Images->new(client => $_[0]) },
);
has networks => (
is => 'lazy',
builder => sub { API::Docker::API::Networks->new(client => $_[0]) },
);
has volumes => (
is => 'lazy',
builder => sub { API::Docker::API::Volumes->new(client => $_[0]) },
);
has exec => (
is => 'lazy',
builder => sub { API::Docker::API::Exec->new(client => $_[0]) },
);
sub negotiate_version {
my ($self) = @_;
return if $self->_version_negotiated;
return if defined $self->api_version;
$log->debug("Auto-negotiating API version");
my $version_info = $self->_request('GET', '/version');
if ($version_info && $version_info->{ApiVersion}) {
$self->_set_api_version($version_info->{ApiVersion});
$log->debugf("Negotiated API version: %s", $version_info->{ApiVersion});
}
$self->_version_negotiated(1);
}
around _request => sub {
my ($orig, $self, $method, $path, %opts) = @_;
# Auto-negotiate before any versioned request, but not for /version itself
if ($path ne '/version' && !defined $self->api_version && !$self->_version_negotiated) {
$self->negotiate_version;
}
return $self->$orig($method, $path, %opts);
};
lib/API/Docker/API/Containers.pm view on Meta::CPAN
use namespace::clean;
has client => (
is => 'ro',
required => 1,
weak_ref => 1,
);
sub _wrap {
my ($self, $data) = @_;
return API::Docker::Container->new(
client => $self->client,
%$data,
);
}
sub _wrap_list {
my ($self, $list) = @_;
return [ map { $self->_wrap($_) } @$list ];
}
sub list {
my ($self, %opts) = @_;
my %params;
$params{all} = $opts{all} ? 1 : 0 if defined $opts{all};
$params{limit} = $opts{limit} if defined $opts{limit};
$params{size} = $opts{size} ? 1 : 0 if defined $opts{size};
$params{filters} = $opts{filters} if defined $opts{filters};
my $result = $self->client->get('/containers/json', params => \%params);
return $self->_wrap_list($result // []);
}
sub create {
my ($self, %config) = @_;
my %params;
$params{name} = delete $config{name} if defined $config{name};
my $result = $self->client->post('/containers/create', \%config, params => \%params);
return $result;
}
sub inspect {
my ($self, $id) = @_;
croak "Container ID required" unless $id;
my $result = $self->client->get("/containers/$id/json");
return $self->_wrap($result);
}
sub start {
my ($self, $id) = @_;
croak "Container ID required" unless $id;
return $self->client->post("/containers/$id/start", undef);
}
sub stop {
my ($self, $id, %opts) = @_;
croak "Container ID required" unless $id;
my %params;
$params{t} = $opts{timeout} if defined $opts{timeout};
$params{signal} = $opts{signal} if defined $opts{signal};
return $self->client->post("/containers/$id/stop", undef, params => \%params);
}
sub restart {
my ($self, $id, %opts) = @_;
croak "Container ID required" unless $id;
my %params;
$params{t} = $opts{timeout} if defined $opts{timeout};
return $self->client->post("/containers/$id/restart", undef, params => \%params);
}
sub kill {
my ($self, $id, %opts) = @_;
croak "Container ID required" unless $id;
my %params;
$params{signal} = $opts{signal} if defined $opts{signal};
return $self->client->post("/containers/$id/kill", undef, params => \%params);
}
sub remove {
my ($self, $id, %opts) = @_;
croak "Container ID required" unless $id;
my %params;
$params{v} = $opts{volumes} ? 1 : 0 if defined $opts{volumes};
$params{force} = $opts{force} ? 1 : 0 if defined $opts{force};
$params{link} = $opts{link} ? 1 : 0 if defined $opts{link};
return $self->client->delete_request("/containers/$id", params => \%params);
}
sub logs {
my ($self, $id, %opts) = @_;
croak "Container ID required" unless $id;
my %params;
$params{stdout} = defined $opts{stdout} ? ($opts{stdout} ? 1 : 0) : 1;
$params{stderr} = defined $opts{stderr} ? ($opts{stderr} ? 1 : 0) : 1;
$params{since} = $opts{since} if defined $opts{since};
$params{until} = $opts{until} if defined $opts{until};
$params{timestamps} = $opts{timestamps} ? 1 : 0 if defined $opts{timestamps};
$params{tail} = $opts{tail} if defined $opts{tail};
return $self->client->get("/containers/$id/logs", params => \%params);
}
sub top {
my ($self, $id, %opts) = @_;
croak "Container ID required" unless $id;
my %params;
$params{ps_args} = $opts{ps_args} if defined $opts{ps_args};
return $self->client->get("/containers/$id/top", params => \%params);
}
sub stats {
my ($self, $id, %opts) = @_;
croak "Container ID required" unless $id;
my %params;
$params{stream} = 0;
$params{'one-shot'} = 1;
return $self->client->get("/containers/$id/stats", params => \%params);
}
sub wait {
my ($self, $id, %opts) = @_;
croak "Container ID required" unless $id;
my %params;
$params{condition} = $opts{condition} if defined $opts{condition};
return $self->client->post("/containers/$id/wait", undef, params => \%params);
}
sub pause {
my ($self, $id) = @_;
croak "Container ID required" unless $id;
return $self->client->post("/containers/$id/pause", undef);
}
sub unpause {
my ($self, $id) = @_;
croak "Container ID required" unless $id;
return $self->client->post("/containers/$id/unpause", undef);
}
sub rename {
my ($self, $id, $name) = @_;
croak "Container ID required" unless $id;
croak "New name required" unless $name;
return $self->client->post("/containers/$id/rename", undef, params => { name => $name });
}
sub update {
my ($self, $id, %config) = @_;
croak "Container ID required" unless $id;
return $self->client->post("/containers/$id/update", \%config);
}
sub prune {
my ($self, %opts) = @_;
my %params;
$params{filters} = $opts{filters} if defined $opts{filters};
return $self->client->post('/containers/prune', undef, params => \%params);
}
1;
lib/API/Docker/API/Exec.pm view on Meta::CPAN
use namespace::clean;
has client => (
is => 'ro',
required => 1,
weak_ref => 1,
);
sub create {
my ($self, $container_id, %config) = @_;
croak "Container ID required" unless $container_id;
croak "Cmd required" unless $config{Cmd};
return $self->client->post("/containers/$container_id/exec", \%config);
}
sub start {
my ($self, $exec_id, %opts) = @_;
croak "Exec ID required" unless $exec_id;
my $body = {
Detach => $opts{Detach} ? \1 : \0,
Tty => $opts{Tty} ? \1 : \0,
};
return $self->client->post("/exec/$exec_id/start", $body);
}
sub resize {
my ($self, $exec_id, %opts) = @_;
croak "Exec ID required" unless $exec_id;
my %params;
$params{h} = $opts{h} if defined $opts{h};
$params{w} = $opts{w} if defined $opts{w};
return $self->client->post("/exec/$exec_id/resize", undef, params => \%params);
}
sub inspect {
my ($self, $exec_id) = @_;
croak "Exec ID required" unless $exec_id;
return $self->client->get("/exec/$exec_id/json");
}
1;
__END__
lib/API/Docker/API/Images.pm view on Meta::CPAN
use namespace::clean;
has client => (
is => 'ro',
required => 1,
weak_ref => 1,
);
sub _wrap {
my ($self, $data) = @_;
return API::Docker::Image->new(
client => $self->client,
%$data,
);
}
sub _wrap_list {
my ($self, $list) = @_;
return [ map { $self->_wrap($_) } @$list ];
}
sub list {
my ($self, %opts) = @_;
my %params;
$params{all} = $opts{all} ? 1 : 0 if defined $opts{all};
$params{digests} = $opts{digests} ? 1 : 0 if defined $opts{digests};
$params{filters} = $opts{filters} if defined $opts{filters};
my $result = $self->client->get('/images/json', params => \%params);
return $self->_wrap_list($result // []);
}
sub build {
my ($self, %opts) = @_;
my $context = delete $opts{context};
croak "Build context required (tar archive as scalar ref or raw bytes)" unless defined $context;
my %params;
$params{dockerfile} = $opts{dockerfile} if defined $opts{dockerfile};
$params{t} = $opts{t} if defined $opts{t};
$params{q} = $opts{q} ? 1 : 0 if defined $opts{q};
$params{nocache} = $opts{nocache} ? 1 : 0 if defined $opts{nocache};
$params{pull} = $opts{pull} if defined $opts{pull};
lib/API/Docker/API/Images.pm view on Meta::CPAN
my $raw = ref $context eq 'SCALAR' ? $$context : $context;
return $self->client->_request('POST', '/build',
raw_body => $raw,
content_type => 'application/x-tar',
params => \%params,
);
}
sub pull {
my ($self, %opts) = @_;
croak "fromImage required" unless $opts{fromImage};
my %params;
$params{fromImage} = $opts{fromImage};
$params{tag} = $opts{tag} // 'latest';
return $self->client->post('/images/create', undef, params => \%params);
}
sub inspect {
my ($self, $name) = @_;
croak "Image name required" unless $name;
my $result = $self->client->get("/images/$name/json");
return $self->_wrap($result);
}
sub history {
my ($self, $name) = @_;
croak "Image name required" unless $name;
return $self->client->get("/images/$name/history");
}
sub push {
my ($self, $name, %opts) = @_;
croak "Image name required" unless $name;
my %params;
$params{tag} = $opts{tag} if defined $opts{tag};
my $auth_header = _build_registry_auth_header($opts{auth});
return $self->client->post(
"/images/$name/push",
undef,
params => \%params,
headers => { 'X-Registry-Auth' => $auth_header },
);
}
sub _build_registry_auth_header {
my ($auth) = @_;
# The Docker Engine requires an X-Registry-Auth header on every push,
# even for anonymous attempts. Encoding is base64url of a JSON object.
require JSON::MaybeXS;
require MIME::Base64;
my $payload;
if (!defined $auth) {
$payload = '{}';
lib/API/Docker/API/Images.pm view on Meta::CPAN
$payload = $auth;
}
my $b64 = MIME::Base64::encode_base64($payload, '');
$b64 =~ tr{+/}{-_};
$b64 =~ s/=+$//;
return $b64;
}
sub tag {
my ($self, $name, %opts) = @_;
croak "Image name required" unless $name;
my %params;
$params{repo} = $opts{repo} if defined $opts{repo};
$params{tag} = $opts{tag} if defined $opts{tag};
return $self->client->post("/images/$name/tag", undef, params => \%params);
}
sub remove {
my ($self, $name, %opts) = @_;
croak "Image name required" unless $name;
my %params;
$params{force} = $opts{force} ? 1 : 0 if defined $opts{force};
$params{noprune} = $opts{noprune} ? 1 : 0 if defined $opts{noprune};
return $self->client->delete_request("/images/$name", params => \%params);
}
sub search {
my ($self, $term, %opts) = @_;
croak "Search term required" unless $term;
my %params;
$params{term} = $term;
$params{limit} = $opts{limit} if defined $opts{limit};
$params{filters} = $opts{filters} if defined $opts{filters};
return $self->client->get('/images/search', params => \%params);
}
sub prune {
my ($self, %opts) = @_;
my %params;
$params{filters} = $opts{filters} if defined $opts{filters};
return $self->client->post('/images/prune', undef, params => \%params);
}
1;
lib/API/Docker/API/Networks.pm view on Meta::CPAN
use namespace::clean;
has client => (
is => 'ro',
required => 1,
weak_ref => 1,
);
sub _wrap {
my ($self, $data) = @_;
return API::Docker::Network->new(
client => $self->client,
%$data,
);
}
sub _wrap_list {
my ($self, $list) = @_;
return [ map { $self->_wrap($_) } @$list ];
}
sub list {
my ($self, %opts) = @_;
my %params;
$params{filters} = $opts{filters} if defined $opts{filters};
my $result = $self->client->get('/networks', params => \%params);
return $self->_wrap_list($result // []);
}
sub inspect {
my ($self, $id) = @_;
croak "Network ID required" unless $id;
my $result = $self->client->get("/networks/$id");
return $self->_wrap($result);
}
sub create {
my ($self, %config) = @_;
croak "Network name required" unless $config{Name};
my $result = $self->client->post('/networks/create', \%config);
return $result;
}
sub remove {
my ($self, $id) = @_;
croak "Network ID required" unless $id;
return $self->client->delete_request("/networks/$id");
}
sub connect {
my ($self, $id, %opts) = @_;
croak "Network ID required" unless $id;
croak "Container required" unless $opts{Container};
return $self->client->post("/networks/$id/connect", \%opts);
}
sub disconnect {
my ($self, $id, %opts) = @_;
croak "Network ID required" unless $id;
croak "Container required" unless $opts{Container};
return $self->client->post("/networks/$id/disconnect", \%opts);
}
sub prune {
my ($self, %opts) = @_;
my %params;
$params{filters} = $opts{filters} if defined $opts{filters};
return $self->client->post('/networks/prune', undef, params => \%params);
}
1;
lib/API/Docker/API/System.pm view on Meta::CPAN
use namespace::clean;
has client => (
is => 'ro',
required => 1,
weak_ref => 1,
);
sub info {
my ($self) = @_;
return $self->client->get('/info');
}
sub version {
my ($self) = @_;
return $self->client->get('/version');
}
sub ping {
my ($self) = @_;
return $self->client->get('/_ping');
}
sub events {
my ($self, %opts) = @_;
my %params;
$params{since} = $opts{since} if defined $opts{since};
$params{until} = $opts{until} if defined $opts{until};
$params{filters} = $opts{filters} if defined $opts{filters};
return $self->client->get('/events', params => \%params);
}
sub df {
my ($self) = @_;
return $self->client->get('/system/df');
}
1;
__END__
lib/API/Docker/API/Volumes.pm view on Meta::CPAN
use namespace::clean;
has client => (
is => 'ro',
required => 1,
weak_ref => 1,
);
sub _wrap {
my ($self, $data) = @_;
return API::Docker::Volume->new(
client => $self->client,
%$data,
);
}
sub _wrap_list {
my ($self, $list) = @_;
return [ map { $self->_wrap($_) } @$list ];
}
sub list {
my ($self, %opts) = @_;
my %params;
$params{filters} = $opts{filters} if defined $opts{filters};
my $result = $self->client->get('/volumes', params => \%params);
return $self->_wrap_list($result->{Volumes} // []);
}
sub create {
my ($self, %config) = @_;
my $result = $self->client->post('/volumes/create', \%config);
return $self->_wrap($result);
}
sub inspect {
my ($self, $name) = @_;
croak "Volume name required" unless $name;
my $result = $self->client->get("/volumes/$name");
return $self->_wrap($result);
}
sub remove {
my ($self, $name, %opts) = @_;
croak "Volume name required" unless $name;
my %params;
$params{force} = $opts{force} ? 1 : 0 if defined $opts{force};
return $self->client->delete_request("/volumes/$name", params => \%params);
}
sub prune {
my ($self, %opts) = @_;
my %params;
$params{filters} = $opts{filters} if defined $opts{filters};
return $self->client->post('/volumes/prune', undef, params => \%params);
}
1;
lib/API/Docker/Container.pm view on Meta::CPAN
has Name => (is => 'ro');
has RestartCount => (is => 'ro');
has Driver => (is => 'ro');
has Platform => (is => 'ro');
has Path => (is => 'ro');
has Args => (is => 'ro');
has Config => (is => 'ro');
sub start {
my ($self) = @_;
return $self->client->containers->start($self->Id);
}
sub stop {
my ($self, %opts) = @_;
return $self->client->containers->stop($self->Id, %opts);
}
sub restart {
my ($self, %opts) = @_;
return $self->client->containers->restart($self->Id, %opts);
}
sub kill {
my ($self, %opts) = @_;
return $self->client->containers->kill($self->Id, %opts);
}
sub remove {
my ($self, %opts) = @_;
return $self->client->containers->remove($self->Id, %opts);
}
sub logs {
my ($self, %opts) = @_;
return $self->client->containers->logs($self->Id, %opts);
}
sub inspect {
my ($self) = @_;
return $self->client->containers->inspect($self->Id);
}
sub pause {
my ($self) = @_;
return $self->client->containers->pause($self->Id);
}
sub unpause {
my ($self) = @_;
return $self->client->containers->unpause($self->Id);
}
sub top {
my ($self, %opts) = @_;
return $self->client->containers->top($self->Id, %opts);
}
sub stats {
my ($self, %opts) = @_;
return $self->client->containers->stats($self->Id, %opts);
}
sub is_running {
my ($self) = @_;
my $state = $self->State;
return 0 unless defined $state;
if (ref $state eq 'HASH') {
return $state->{Running} ? 1 : 0;
}
return lc($state) eq 'running' ? 1 : 0;
}
lib/API/Docker/Image.pm view on Meta::CPAN
has VirtualSize => (is => 'ro');
has Labels => (is => 'ro');
has Containers => (is => 'ro');
has Architecture => (is => 'ro');
has Os => (is => 'ro');
has Config => (is => 'ro');
has RootFS => (is => 'ro');
has Metadata => (is => 'ro');
sub inspect {
my ($self) = @_;
return $self->client->images->inspect($self->Id);
}
sub history {
my ($self) = @_;
return $self->client->images->history($self->Id);
}
sub tag {
my ($self, %opts) = @_;
return $self->client->images->tag($self->Id, %opts);
}
sub remove {
my ($self, %opts) = @_;
return $self->client->images->remove($self->Id, %opts);
}
1;
__END__
lib/API/Docker/Network.pm view on Meta::CPAN
has IPAM => (is => 'ro');
has Internal => (is => 'ro');
has Attachable => (is => 'ro');
has Ingress => (is => 'ro');
has Options => (is => 'ro');
has Labels => (is => 'ro');
has Containers => (is => 'ro');
has ConfigFrom => (is => 'ro');
has ConfigOnly => (is => 'ro');
sub inspect {
my ($self) = @_;
return $self->client->networks->inspect($self->Id);
}
sub remove {
my ($self) = @_;
return $self->client->networks->remove($self->Id);
}
sub connect {
my ($self, %opts) = @_;
return $self->client->networks->connect($self->Id, %opts);
}
sub disconnect {
my ($self, %opts) = @_;
return $self->client->networks->disconnect($self->Id, %opts);
}
1;
__END__
lib/API/Docker/Role/HTTP.pm view on Meta::CPAN
requires 'host';
requires 'api_version';
has _socket => (
is => 'lazy',
clearer => '_clear_socket',
);
sub _build__socket {
my ($self) = @_;
my $host = $self->host;
if ($host =~ m{^unix://(.+)$}) {
my $path = $1;
$log->debugf("Connecting to Unix socket: %s", $path);
my $sock = IO::Socket::UNIX->new(
Peer => $path,
Type => SOCK_STREAM,
);
lib/API/Docker/Role/HTTP.pm view on Meta::CPAN
Proto => 'tcp',
);
croak "Cannot connect to $addr:$port: $!" unless $sock;
return $sock;
}
else {
croak "Unsupported host format: $host (expected unix:// or tcp://)";
}
}
sub _reconnect {
my ($self) = @_;
$self->_clear_socket;
return $self->_socket;
}
sub _request {
my ($self, $method, $path, %opts) = @_;
my $version = $self->api_version;
my $url_path = defined $version ? "/v$version$path" : $path;
my $body_content = '';
my $content_type = 'application/json';
if ($opts{raw_body}) {
$body_content = $opts{raw_body};
$content_type = $opts{content_type} // 'application/x-tar';
lib/API/Docker/Role/HTTP.pm view on Meta::CPAN
next unless $line =~ /\S/;
my $obj = eval { decode_json($line) };
push @objects, $obj if defined $obj;
}
return \@objects if @objects;
}
return $body;
}
sub _read_response {
my ($self, $sock) = @_;
my $status_line = <$sock>;
croak "No response from Docker daemon" unless defined $status_line;
$status_line =~ s/\r?\n$//;
my ($proto, $status_code, $status_text) = split /\s+/, $status_line, 3;
my %headers;
while (my $line = <$sock>) {
lib/API/Docker/Role/HTTP.pm view on Meta::CPAN
}
}
else {
local $/;
$body = <$sock> // '';
}
return [$status_code, $status_text, \%headers, $body];
}
sub _read_chunked {
my ($self, $sock) = @_;
my $body = '';
while (1) {
my $chunk_header = <$sock>;
last unless defined $chunk_header;
$chunk_header =~ s/\r?\n$//;
my $chunk_size = hex($chunk_header);
last if $chunk_size == 0;
lib/API/Docker/Role/HTTP.pm view on Meta::CPAN
}
$body .= $chunk;
# Read trailing \r\n after chunk data
<$sock>;
}
return $body;
}
sub _uri_encode {
my ($str) = @_;
$str =~ s/([^A-Za-z0-9\-_.~:\/])/sprintf("%%%02X", ord($1))/ge;
return $str;
}
sub get {
my ($self, $path, %opts) = @_;
return $self->_request('GET', $path, %opts);
}
sub post {
my ($self, $path, $body, %opts) = @_;
$opts{body} = $body if defined $body;
return $self->_request('POST', $path, %opts);
}
sub put {
my ($self, $path, $body, %opts) = @_;
$opts{body} = $body if defined $body;
return $self->_request('PUT', $path, %opts);
}
sub delete_request {
my ($self, $path, %opts) = @_;
return $self->_request('DELETE', $path, %opts);
}
1;
__END__
lib/API/Docker/Volume.pm view on Meta::CPAN
has Mountpoint => (is => 'ro');
has CreatedAt => (is => 'ro');
has Status => (is => 'ro');
has Labels => (is => 'ro');
has Scope => (is => 'ro');
has Options => (is => 'ro');
has UsageData => (is => 'ro');
sub inspect {
my ($self) = @_;
return $self->client->volumes->inspect($self->Name);
}
sub remove {
my ($self, %opts) = @_;
return $self->client->volumes->remove($self->Name, %opts);
}
1;
__END__
t/containers.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
use lib 't/lib';
use Test::API::Docker::Mock;
check_live_access();
# --- Read Tests (always run) ---
subtest 'list containers' => sub {
my $docker = test_docker(
'GET /containers/json' => load_fixture('containers_list'),
);
my $containers = $docker->containers->list(all => 1);
is(ref $containers, 'ARRAY', 'returns array');
if (@$containers) {
isa_ok($containers->[0], 'API::Docker::Container');
ok($containers->[0]->Id, 'has Id');
t/containers.t view on Meta::CPAN
my $second = $containers->[1];
is($second->Id, 'def789ghi012', 'second container id');
is($second->State, 'exited', 'second container state');
ok(!$second->is_running, 'is_running returns false for exited container');
}
};
# --- Write Tests (mock always, live only with WRITE) ---
subtest 'container lifecycle' => sub {
skip_unless_write();
my $docker = test_docker(
'POST /containers/create' => { Id => 'mock123', Warnings => [] },
'POST /containers/mock123/start' => undef,
'GET /containers/mock123/json' => load_fixture('container_inspect'),
'GET /containers/mock123/top' => {
Titles => ['UID', 'PID', 'PPID', 'C', 'STIME', 'TTY', 'TIME', 'CMD'],
Processes => [
['root', '12345', '1', '0', '08:00', '?', '00:00:00', 'sleep'],
t/containers.t view on Meta::CPAN
my $name = 'api-docker-test-' . $$;
my $created = $docker->containers->create(
name => $name,
Image => 'alpine:latest',
Cmd => ['sleep', '10'],
);
ok($created->{Id}, 'created container has Id');
my $id = is_live() ? $created->{Id} : 'mock123';
register_cleanup(sub { $docker->containers->remove($id, force => 1) }) if is_live();
$docker->containers->start($id);
pass('container started');
my $container = $docker->containers->inspect($id);
isa_ok($container, 'API::Docker::Container');
ok($container->is_running, 'container is running');
my $top = $docker->containers->top($id);
is(ref $top->{Processes}, 'ARRAY', 'top has processes');
t/containers.t view on Meta::CPAN
$docker->containers->stop($id, timeout => 3);
pass('container stopped');
$docker->containers->remove($id);
pass('container removed');
};
# --- Validation Tests (always run, no Docker needed) ---
subtest 'container ID required' => sub {
my $docker = test_docker();
eval { $docker->containers->inspect(undef) };
like($@, qr/Container ID required/, 'croak on missing ID for inspect');
eval { $docker->containers->start(undef) };
like($@, qr/Container ID required/, 'croak on missing ID for start');
eval { $docker->containers->stop(undef) };
like($@, qr/Container ID required/, 'croak on missing ID for stop');
use strict;
use warnings;
use Test::More;
use lib 't/lib';
use Test::API::Docker::Mock;
check_live_access();
# --- Read Tests (always run) ---
subtest 'list images' => sub {
my $docker = test_docker(
'GET /images/json' => load_fixture('images_list'),
);
my $images = $docker->images->list;
is(ref $images, 'ARRAY', 'returns array');
if (@$images) {
isa_ok($images->[0], 'API::Docker::Image');
ok($images->[0]->Id, 'has Id');
is(scalar @$images, 2, 'two images');
my $first = $images->[0];
like($first->Id, qr/^sha256:abc123/, 'image id');
is_deeply($first->RepoTags, ['nginx:latest', 'nginx:1.25'], 'repo tags');
is($first->Size, 187654321, 'image size');
is($first->Containers, 2, 'container count');
}
};
subtest 'inspect image' => sub {
my $docker = test_docker(
'GET /images/nginx:latest/json' => {
Id => 'sha256:abc123',
RepoTags => ['nginx:latest'],
Architecture => 'amd64',
Os => 'linux',
Size => 187654321,
Config => {
Cmd => ['nginx', '-g', 'daemon off;'],
},
isa_ok($image, 'API::Docker::Image');
ok($image->Id, 'has Id');
unless (is_live()) {
is($image->Id, 'sha256:abc123', 'image id');
is($image->Architecture, 'amd64', 'architecture');
is($image->Os, 'linux', 'os');
}
};
subtest 'image history' => sub {
my $docker = test_docker(
'GET /images/nginx:latest/history' => [
{
Id => 'sha256:abc123',
Created => 1705300000,
CreatedBy => '/bin/sh -c #(nop) CMD ["nginx" "-g" "daemon off;"]',
Size => 0,
},
{
Id => 'sha256:def456',
$history = $docker->images->history('nginx:latest');
}
is(ref $history, 'ARRAY', 'history is array');
unless (is_live()) {
is(scalar @$history, 2, 'two history entries');
}
};
subtest 'search images' => sub {
my $docker = test_docker(
'GET /images/search' => [
{
name => 'nginx',
description => 'Official nginx image',
star_count => 19000,
is_official => 1,
is_automated => 0,
},
],
is(ref $results, 'ARRAY', 'search returns array');
unless (is_live()) {
is($results->[0]{name}, 'nginx', 'found nginx');
}
};
# --- Write Tests (mock always, live only with WRITE) ---
subtest 'image build and pull lifecycle' => sub {
skip_unless_write();
my $docker = test_docker(
'POST /build' => sub {
my ($method, $path, %opts) = @_;
ok(defined $opts{raw_body}, 'raw_body present in request');
is($opts{content_type}, 'application/x-tar', 'content type is tar');
return { stream => 'Successfully built abc123def456' };
},
'POST /images/create' => sub {
my ($method, $path, %opts) = @_;
return '';
},
'POST /images/nginx:latest/tag' => undef,
'DELETE /images/nginx:latest' => [
{ Untagged => 'nginx:latest' },
{ Deleted => 'sha256:abc123' },
],
);
substr($header, 148, 8, sprintf('%06o', $checksum) . "\0 ");
my $tar = $header;
$tar .= $dockerfile;
$tar .= "\0" x (512 - ($size % 512)) if $size % 512;
$tar .= "\0" x 1024;
my $tag = 'api-docker-test-build:latest';
my $result = $docker->images->build(context => $tar, t => $tag, q => 1);
ok($result, 'build returned result');
register_cleanup(sub { eval { $docker->images->remove($tag, force => 1) } });
} else {
my $result = $docker->images->build(
context => 'fake-tar-data',
t => 'myapp:latest',
dockerfile => 'Dockerfile',
);
ok($result, 'build returned a result');
like($result->{stream}, qr/Successfully built/, 'build output contains success');
$docker->images->pull(fromImage => 'nginx', tag => 'latest');
$docker->images->tag('nginx:latest', repo => 'myrepo/nginx', tag => 'v1');
pass('tag completed');
my $removed = $docker->images->remove('nginx:latest');
is(ref $removed, 'ARRAY', 'remove returns array of actions');
}
};
# --- Validation Tests (always run, no Docker needed) ---
subtest 'build requires context' => sub {
my $docker = test_docker();
eval { $docker->images->build(t => 'myapp:latest') };
like($@, qr/Build context required/, 'croak on missing context');
};
subtest 'image name required' => sub {
my $docker = test_docker();
eval { $docker->images->inspect(undef) };
like($@, qr/Image name required/, 'croak on missing name for inspect');
eval { $docker->images->remove(undef) };
like($@, qr/Image name required/, 'croak on missing name for remove');
};
done_testing;
t/images_push_auth.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
use JSON::MaybeXS qw( decode_json );
use MIME::Base64 qw( decode_base64 decode_base64url );
use API::Docker::API::Images;
sub b64url_decode {
my ($s) = @_;
$s =~ tr{-_}{+/};
my $pad = (4 - length($s) % 4) % 4;
$s .= '=' x $pad;
return decode_base64($s);
}
subtest 'empty/undef auth -> base64url("{}")' => sub {
my $hdr = API::Docker::API::Images::_build_registry_auth_header(undef);
ok length($hdr), 'header is non-empty for undef';
is_deeply(decode_json(b64url_decode($hdr)), {},
'decodes to empty JSON object');
};
subtest 'hashref auth -> JSON-encoded credentials' => sub {
my $auth = {
username => 'me',
password => 'secret',
serveraddress => 'https://index.docker.io/v1/',
};
my $hdr = API::Docker::API::Images::_build_registry_auth_header($auth);
is_deeply(decode_json(b64url_decode($hdr)), $auth,
'header roundtrips through base64url + JSON');
};
subtest 'identitytoken auth' => sub {
my $auth = { identitytoken => 'tok-123', serveraddress => 'ghcr.io' };
my $hdr = API::Docker::API::Images::_build_registry_auth_header($auth);
is_deeply(decode_json(b64url_decode($hdr)), $auth,
'identitytoken roundtrips');
};
subtest 'pre-encoded base64-like string passes through' => sub {
my $pre = 'eyJ1IjoibWUifQ';
is API::Docker::API::Images::_build_registry_auth_header($pre), $pre,
'string passed through unchanged';
};
subtest 'push() sends X-Registry-Auth via _request' => sub {
require API::Docker;
my $docker = API::Docker->new(
host => 'unix:///dev/null',
api_version => '1.47',
);
my $captured;
my $mock = sub {
my ($self, $method, $path, %opts) = @_;
$captured = { method => $method, path => $path, %opts };
return [];
};
no warnings 'redefine';
local *API::Docker::_request = $mock;
$docker->images->push(
'raudssus/karr:user',
t/lib/Test/API/Docker/Mock.pm view on Meta::CPAN
can_write
skip_unless_write
check_live_access
register_cleanup
);
my $FIXTURES_DIR = path(__FILE__)->parent->parent->parent->parent->parent->child('fixtures');
my @_cleanups;
sub load_fixture {
my ($name) = @_;
my $file = $FIXTURES_DIR->child("$name.json");
croak "Fixture not found: $file" unless $file->exists;
return decode_json($file->slurp_utf8);
}
sub is_live {
return !!$ENV{API_DOCKER_TEST_HOST};
}
sub can_write {
return is_live() && !!$ENV{API_DOCKER_TEST_WRITE};
}
sub skip_unless_write {
if (is_live() && !can_write()) {
plan skip_all => 'Write tests skipped (set API_DOCKER_TEST_WRITE=1 to enable)';
}
}
sub check_live_access {
return unless is_live();
my $host = $ENV{API_DOCKER_TEST_HOST};
if ($host =~ m{^unix://(.+)$}) {
unless (-S $1) {
plan skip_all => "Docker socket $1 not available";
}
}
eval {
require API::Docker;
my $docker = API::Docker->new(host => $host);
my $result = $docker->system->ping;
die "ping failed" unless $result eq 'OK';
};
if ($@) {
plan skip_all => "Docker daemon not reachable at $host: $@";
}
}
sub register_cleanup {
my ($code) = @_;
push @_cleanups, $code;
}
sub _run_cleanups {
for my $cleanup (reverse @_cleanups) {
eval { $cleanup->() };
warn "Cleanup failed: $@" if $@;
}
@_cleanups = ();
}
sub test_docker {
my (%routes) = @_;
if (is_live()) {
require API::Docker;
return API::Docker->new(host => $ENV{API_DOCKER_TEST_HOST});
}
return _mock_docker(%routes);
}
sub _mock_docker {
my (%routes) = @_;
unless (grep { /version/ } keys %routes) {
$routes{'GET /version'} = load_fixture('system_version');
}
require API::Docker;
my $docker = API::Docker->new(
host => 'unix:///var/run/docker.sock',
api_version => '1.47',
);
my $mock_request = sub {
my ($self, $method, $path, %opts) = @_;
my $clean_path = $path;
$clean_path =~ s{^/v[\d.]+}{};
my $key = "$method $clean_path";
if (exists $routes{$key}) {
my $handler = $routes{$key};
if (ref $handler eq 'CODE') {
t/networks.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
use lib 't/lib';
use Test::API::Docker::Mock;
check_live_access();
# --- Read Tests (always run) ---
subtest 'list networks' => sub {
my $docker = test_docker(
'GET /networks' => load_fixture('networks_list'),
);
my $networks = $docker->networks->list;
is(ref $networks, 'ARRAY', 'returns array');
if (@$networks) {
isa_ok($networks->[0], 'API::Docker::Network');
ok($networks->[0]->Name, 'has Name');
t/networks.t view on Meta::CPAN
my $first = $networks->[0];
is($first->Name, 'bridge', 'network name');
is($first->Driver, 'bridge', 'network driver');
is($first->Scope, 'local', 'network scope');
ok(!$first->Internal, 'not internal');
}
};
# --- Write Tests (mock always, live only with WRITE) ---
subtest 'network lifecycle' => sub {
skip_unless_write();
my $docker = test_docker(
'POST /networks/create' => sub {
my ($method, $path, %opts) = @_;
is($opts{body}{Name}, 'test-net', 'network name in body') unless is_live();
return { Id => 'mock-net-123', Warning => '' };
},
'GET /networks/mock-net-123' => {
Name => 'test-net',
Id => 'mock-net-123',
Driver => 'bridge',
Scope => 'local',
Labels => {},
t/networks.t view on Meta::CPAN
);
my $name = 'api-docker-test-net-' . $$;
my $result = $docker->networks->create(
Name => is_live() ? $name : 'test-net',
Driver => 'bridge',
);
ok($result->{Id}, 'created network has Id');
my $id = is_live() ? $result->{Id} : 'mock-net-123';
register_cleanup(sub { eval { $docker->networks->remove($id) } }) if is_live();
my $network = $docker->networks->inspect($id);
isa_ok($network, 'API::Docker::Network');
ok($network->Name, 'has Name');
unless (is_live()) {
$docker->networks->connect($id, Container => 'abc123');
pass('connect completed');
$docker->networks->disconnect($id, Container => 'abc123');
pass('disconnect completed');
}
$docker->networks->remove($id);
pass('network removed');
};
# --- Validation Tests (always run, no Docker needed) ---
subtest 'network ID required' => sub {
my $docker = test_docker();
eval { $docker->networks->inspect(undef) };
like($@, qr/Network ID required/, 'croak on missing ID for inspect');
eval { $docker->networks->remove(undef) };
like($@, qr/Network ID required/, 'croak on missing ID for remove');
};
subtest 'connect requires container' => sub {
my $docker = test_docker();
eval { $docker->networks->connect('net1') };
like($@, qr/Container required/, 'croak on missing container for connect');
};
done_testing;
t/release-changes_has_content.t view on Meta::CPAN
SKIP: {
ok(-e $changes_file, "$changes_file file exists")
or skip 'Changes is missing', 1;
ok(_get_changes($newver), "$changes_file has content for $newver");
}
done_testing;
sub _get_changes
{
my $newver = shift;
# parse changelog to find commit message
open(my $fh, '<', $changes_file) or die "cannot open $changes_file: $!";
my $changelog = join('', <$fh>);
if ($encoding) {
require Encode;
$changelog = Encode::decode($encoding, $changelog, Encode::FB_CROAK());
}
use strict;
use warnings;
use Test::More;
use lib 't/lib';
use Test::API::Docker::Mock;
check_live_access();
subtest 'system info' => sub {
my $docker = test_docker(
'GET /info' => load_fixture('system_info'),
);
my $info = $docker->system->info;
ok(defined $info->{Containers}, 'has Containers');
ok(defined $info->{Images}, 'has Images');
ok($info->{ServerVersion}, 'has ServerVersion');
ok($info->{OperatingSystem}, 'has OperatingSystem');
is($info->{Images}, 25, 'image count');
is($info->{Driver}, 'overlay2', 'storage driver');
is($info->{Name}, 'test-host', 'hostname');
is($info->{ServerVersion}, '27.4.1', 'server version');
is($info->{OperatingSystem}, 'Debian GNU/Linux 12 (bookworm)', 'os');
is($info->{Architecture}, 'x86_64', 'architecture');
is($info->{NCPU}, 4, 'cpu count');
}
};
subtest 'system version' => sub {
my $docker = test_docker(
'GET /version' => load_fixture('system_version'),
);
my $version = $docker->system->version;
ok($version->{Version}, 'has Version');
ok($version->{ApiVersion}, 'has ApiVersion');
ok($version->{Os}, 'has Os');
ok($version->{Arch}, 'has Arch');
unless (is_live()) {
is($version->{Version}, '27.4.1', 'docker version');
is($version->{ApiVersion}, '1.47', 'api version');
is($version->{MinAPIVersion}, '1.24', 'min api version');
is($version->{Os}, 'linux', 'os');
is($version->{Arch}, 'amd64', 'arch');
}
};
subtest 'ping' => sub {
my $docker = test_docker(
'GET /_ping' => 'OK',
);
my $result = $docker->system->ping;
is($result, 'OK', 'ping returns OK');
};
subtest 'system df' => sub {
my $docker = test_docker(
'GET /system/df' => {
LayersSize => 1000000000,
Images => [
{ Id => 'sha256:abc', Size => 500000000, SharedSize => 200000000 },
],
Containers => [
{ Id => 'abc123', SizeRw => 10000, SizeRootFs => 500000000 },
],
Volumes => [
is(ref $df->{Volumes}, 'ARRAY', 'has Volumes array');
unless (is_live()) {
is($df->{LayersSize}, 1000000000, 'layers size');
is(scalar @{$df->{Images}}, 1, 'one image');
is(scalar @{$df->{Containers}}, 1, 'one container');
is(scalar @{$df->{Volumes}}, 1, 'one volume');
}
};
subtest 'events' => sub {
my $docker = test_docker(
'GET /events' => [
{
Type => 'container',
Action => 'start',
Actor => { ID => 'abc123' },
time => 1705300000,
},
],
);
t/version.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
use lib 't/lib';
use Test::API::Docker::Mock;
check_live_access();
subtest 'version info' => sub {
my $docker = test_docker(
'GET /version' => load_fixture('system_version'),
);
my $version = $docker->system->version;
ok($version->{ApiVersion}, 'has ApiVersion');
ok($version->{Version}, 'has Version');
ok($version->{Os}, 'has Os');
ok($version->{Arch}, 'has Arch');
t/version.t view on Meta::CPAN
unless (is_live()) {
is($version->{ApiVersion}, '1.47', 'ApiVersion correct');
is($version->{Version}, '27.4.1', 'Version correct');
is($version->{Os}, 'linux', 'Os correct');
is($version->{Arch}, 'amd64', 'Arch correct');
is($version->{GoVersion}, 'go1.22.10', 'GoVersion correct');
is($version->{MinAPIVersion}, '1.24', 'MinAPIVersion correct');
}
};
subtest 'explicit version skips negotiation' => sub {
my $docker = API::Docker->new(api_version => '1.45');
is($docker->api_version, '1.45', 'explicit version preserved');
};
subtest 'auto-negotiate version' => sub {
if (is_live()) {
my $docker = API::Docker->new(host => $ENV{API_DOCKER_TEST_HOST});
$docker->negotiate_version;
ok(defined $docker->api_version, 'api_version negotiated');
like($docker->api_version, qr/^\d+\.\d+$/, 'version looks valid');
} else {
my $docker = test_docker(
'GET /version' => load_fixture('system_version'),
);
is($docker->api_version, '1.47', 'api_version matches fixture');
t/volumes.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
use lib 't/lib';
use Test::API::Docker::Mock;
check_live_access();
# --- Read Tests (always run) ---
subtest 'list volumes' => sub {
my $docker = test_docker(
'GET /volumes' => load_fixture('volumes_list'),
);
my $volumes = $docker->volumes->list;
is(ref $volumes, 'ARRAY', 'returns array');
if (@$volumes) {
isa_ok($volumes->[0], 'API::Docker::Volume');
ok($volumes->[0]->Name, 'has Name');
t/volumes.t view on Meta::CPAN
is($first->Name, 'my-data', 'volume name');
is($first->Driver, 'local', 'volume driver');
is($first->Scope, 'local', 'volume scope');
is_deeply($first->Labels, { project => 'test' }, 'volume labels');
like($first->Mountpoint, qr{/var/lib/docker/volumes/my-data}, 'mountpoint');
}
};
# --- Write Tests (mock always, live only with WRITE) ---
subtest 'volume lifecycle' => sub {
skip_unless_write();
my $docker = test_docker(
'POST /volumes/create' => sub {
my ($method, $path, %opts) = @_;
is($opts{body}{Name}, 'test-vol', 'volume name in body') unless is_live();
return {
Name => 'test-vol',
Driver => 'local',
Mountpoint => '/var/lib/docker/volumes/test-vol/_data',
CreatedAt => '2025-01-15T12:00:00Z',
Labels => {},
Scope => 'local',
Options => {},
t/volumes.t view on Meta::CPAN
Options => {},
},
'DELETE /volumes/test-vol' => undef,
);
my $name = is_live() ? 'api-docker-test-vol-' . $$ : 'test-vol';
my $volume = $docker->volumes->create(Name => $name);
isa_ok($volume, 'API::Docker::Volume');
ok($volume->Name, 'created volume has Name');
register_cleanup(sub { eval { $docker->volumes->remove($name, force => 1) } }) if is_live();
my $inspected = $docker->volumes->inspect($name);
isa_ok($inspected, 'API::Docker::Volume');
is($inspected->Driver, 'local', 'volume driver is local');
$docker->volumes->remove($name);
pass('volume removed');
};
# --- Validation Tests (always run, no Docker needed) ---
subtest 'volume name required' => sub {
my $docker = test_docker();
eval { $docker->volumes->inspect(undef) };
like($@, qr/Volume name required/, 'croak on missing name for inspect');
eval { $docker->volumes->remove(undef) };
like($@, qr/Volume name required/, 'croak on missing name for remove');
};
done_testing;
( run in 1.241 second using v1.01-cache-2.11-cpan-7fcb06a456a )