mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-11 13:40:07 +00:00
Partly working and tested pt-agent. Fix Percona/WebAPI/Client.pm. Add Percona/WebAPI/Util.pm, Percona/Test.pm, and /Test/Mock/UserAgent.pm.
This commit is contained in:
200
bin/pt-agent
200
bin/pt-agent
@@ -17,13 +17,13 @@ BEGIN {
|
|||||||
Lmo::Meta
|
Lmo::Meta
|
||||||
Lmo::Object
|
Lmo::Object
|
||||||
Lmo
|
Lmo
|
||||||
|
Percona::WebAPI::Representation
|
||||||
Percona::WebAPI::Client
|
Percona::WebAPI::Client
|
||||||
Percona::WebAPI::Exception::Request
|
Percona::WebAPI::Exception::Request
|
||||||
Percona::WebAPI::Resource::Agent
|
Percona::WebAPI::Resource::Agent
|
||||||
Percona::WebAPI::Resource::Config
|
Percona::WebAPI::Resource::Config
|
||||||
Percona::WebAPI::Resource::Service
|
Percona::WebAPI::Resource::Service
|
||||||
Percona::WebAPI::Resource::Run
|
Percona::WebAPI::Resource::Run
|
||||||
Percona::WebAPI::Representation
|
|
||||||
Percona::WebAPI::Util
|
Percona::WebAPI::Util
|
||||||
VersionCheck
|
VersionCheck
|
||||||
DSNParser
|
DSNParser
|
||||||
@@ -56,12 +56,10 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|||||||
|
|
||||||
use Carp qw(carp cluck);
|
use Carp qw(carp cluck);
|
||||||
use Data::Dumper qw();
|
use Data::Dumper qw();
|
||||||
$Data::Dumper::Indent = 1;
|
|
||||||
$Data::Dumper::Sortkeys = 1;
|
|
||||||
$Data::Dumper::Quotekeys = 0;
|
|
||||||
|
|
||||||
use Exporter 'import';
|
require Exporter;
|
||||||
our @EXPORT = qw(
|
our @ISA = qw(Exporter);
|
||||||
|
our @EXPORT_OK = qw(
|
||||||
have_required_args
|
have_required_args
|
||||||
Dumper
|
Dumper
|
||||||
_d
|
_d
|
||||||
@@ -81,6 +79,9 @@ sub have_required_args {
|
|||||||
}
|
}
|
||||||
|
|
||||||
sub Dumper {
|
sub Dumper {
|
||||||
|
local $Data::Dumper::Indent = 1;
|
||||||
|
local $Data::Dumper::Sortkeys = 1;
|
||||||
|
local $Data::Dumper::Quotekeys = 0;
|
||||||
Data::Dumper::Dumper(@_);
|
Data::Dumper::Dumper(@_);
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -671,6 +672,56 @@ BEGIN {
|
|||||||
# End Lmo package
|
# End Lmo package
|
||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
|
|
||||||
|
# ###########################################################################
|
||||||
|
# Percona::WebAPI::Representation package
|
||||||
|
# This package is a copy without comments from the original. The original
|
||||||
|
# with comments and its test file can be found in the Bazaar repository at,
|
||||||
|
# lib/Percona/WebAPI/Representation.pm
|
||||||
|
# t/lib/Percona/WebAPI/Representation.t
|
||||||
|
# See https://launchpad.net/percona-toolkit for more information.
|
||||||
|
# ###########################################################################
|
||||||
|
{
|
||||||
|
package Percona::WebAPI::Representation;
|
||||||
|
|
||||||
|
use JSON;
|
||||||
|
|
||||||
|
require Exporter;
|
||||||
|
our @ISA = qw(Exporter);
|
||||||
|
our @EXPORT_OK = qw(
|
||||||
|
as_hashref
|
||||||
|
as_json
|
||||||
|
as_config
|
||||||
|
);
|
||||||
|
|
||||||
|
sub as_hashref {
|
||||||
|
my $resource = shift;
|
||||||
|
|
||||||
|
my $as_hashref = { %$resource };
|
||||||
|
|
||||||
|
delete $as_hashref->{links};
|
||||||
|
|
||||||
|
return $as_hashref;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub as_json {
|
||||||
|
return encode_json(as_hashref(@_));
|
||||||
|
}
|
||||||
|
|
||||||
|
sub as_config {
|
||||||
|
my $as_hashref = as_hashref(@_);
|
||||||
|
my $config = join("\n",
|
||||||
|
map { defined $as_hashref->{$_} ? "$_=$as_hashref->{$_}" : "$_" }
|
||||||
|
sort keys %$as_hashref
|
||||||
|
) . "\n";
|
||||||
|
return $config;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
}
|
||||||
|
# ###########################################################################
|
||||||
|
# End Percona::WebAPI::Representation package
|
||||||
|
# ###########################################################################
|
||||||
|
|
||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
# Percona::WebAPI::Client package
|
# Percona::WebAPI::Client package
|
||||||
# This package is a copy without comments from the original. The original
|
# This package is a copy without comments from the original. The original
|
||||||
@@ -696,8 +747,12 @@ use English qw(-no_match_vars);
|
|||||||
|
|
||||||
use Lmo;
|
use Lmo;
|
||||||
use Percona::Toolkit;
|
use Percona::Toolkit;
|
||||||
|
use Percona::WebAPI::Representation;
|
||||||
use Percona::WebAPI::Exception::Request;
|
use Percona::WebAPI::Exception::Request;
|
||||||
|
|
||||||
|
Percona::WebAPI::Representation->import(qw(as_json));
|
||||||
|
Percona::Toolkit->import(qw(_d Dumper have_required_args));
|
||||||
|
|
||||||
has 'api_key' => (
|
has 'api_key' => (
|
||||||
is => 'ro',
|
is => 'ro',
|
||||||
isa => 'Str',
|
isa => 'Str',
|
||||||
@@ -707,8 +762,8 @@ has 'api_key' => (
|
|||||||
has 'base_url' => (
|
has 'base_url' => (
|
||||||
is => 'rw',
|
is => 'rw',
|
||||||
isa => 'Str',
|
isa => 'Str',
|
||||||
default => 'https://api.tools.percona.com',
|
default => sub { return 'https://api.tools.percona.com' },
|
||||||
required => 1,
|
required => 0,
|
||||||
);
|
);
|
||||||
|
|
||||||
has 'links' => (
|
has 'links' => (
|
||||||
@@ -720,7 +775,7 @@ has 'links' => (
|
|||||||
|
|
||||||
has 'ua' => (
|
has 'ua' => (
|
||||||
is => 'rw',
|
is => 'rw',
|
||||||
isa => 'LWP::UserAgent',
|
isa => 'Object',
|
||||||
lazy => 1,
|
lazy => 1,
|
||||||
required => 1,
|
required => 1,
|
||||||
builder => '_build_ua',
|
builder => '_build_ua',
|
||||||
@@ -759,7 +814,7 @@ sub BUILD {
|
|||||||
}
|
}
|
||||||
|
|
||||||
my $entry_links = decode_json($self->response->content);
|
my $entry_links = decode_json($self->response->content);
|
||||||
PTDEBUG && _d('Entry links', $entry_links);
|
PTDEBUG && _d('Entry links', Dumper($entry_links));
|
||||||
|
|
||||||
$self->links($entry_links);
|
$self->links($entry_links);
|
||||||
|
|
||||||
@@ -769,17 +824,17 @@ sub BUILD {
|
|||||||
sub get {
|
sub get {
|
||||||
my ($self, %args) = @_;
|
my ($self, %args) = @_;
|
||||||
|
|
||||||
my @required_args = (
|
have_required_args(\%args, qw(
|
||||||
'link', # A resource link (e.g. $run->links->{results})
|
url
|
||||||
);
|
)) or die;
|
||||||
my ($link) = @args{@required_args};
|
my ($url) = $args{url};
|
||||||
|
|
||||||
my @resources; # Resources from the requested link
|
my @resources;
|
||||||
|
|
||||||
eval {
|
eval {
|
||||||
$self->_request(
|
$self->_request(
|
||||||
method => 'GET',
|
method => 'GET',
|
||||||
url => $link,
|
url => $url,
|
||||||
);
|
);
|
||||||
};
|
};
|
||||||
if ( my $e = $EVAL_ERROR ) {
|
if ( my $e = $EVAL_ERROR ) {
|
||||||
@@ -839,18 +894,26 @@ sub post {
|
|||||||
);
|
);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
sub put {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->_set(
|
||||||
|
@_,
|
||||||
|
method => 'PUT',
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
sub delete {
|
sub delete {
|
||||||
my ($self, %args) = @_;
|
my ($self, %args) = @_;
|
||||||
|
|
||||||
my @required_args = (
|
have_required_args(\%args, qw(
|
||||||
'link', # A resource link (e.g. $run->links->{results})
|
url
|
||||||
);
|
)) or die;
|
||||||
my ($link) = @args{@required_args};
|
my ($url) = $args{url};
|
||||||
|
|
||||||
eval {
|
eval {
|
||||||
$self->_request(
|
$self->_request(
|
||||||
method => 'DELETE',
|
method => 'DELETE',
|
||||||
url => $link,
|
url => $url,
|
||||||
headers => { 'Content-Length' => 0 },
|
headers => { 'Content-Length' => 0 },
|
||||||
);
|
);
|
||||||
};
|
};
|
||||||
@@ -868,12 +931,19 @@ sub delete {
|
|||||||
|
|
||||||
sub _set {
|
sub _set {
|
||||||
my ($self, %args) = @_;
|
my ($self, %args) = @_;
|
||||||
my @required_args = qw(method resources link);
|
|
||||||
my ($method, $res, $link) = @args{@required_args};
|
have_required_args(\%args, qw(
|
||||||
|
method
|
||||||
|
resources
|
||||||
|
url
|
||||||
|
)) or die;
|
||||||
|
my $method = $args{method};
|
||||||
|
my $res = $args{resources};
|
||||||
|
my $url = $args{url};
|
||||||
|
|
||||||
my $content;
|
my $content;
|
||||||
if ( ref($res) eq 'ARRAY' ) {
|
if ( ref($res) eq 'ARRAY' ) {
|
||||||
$content = '[' . join(",\n", map { $_->as_json } @$res) . ']';
|
$content = '[' . join(",\n", map { as_json($_) } @$res) . ']';
|
||||||
}
|
}
|
||||||
elsif ( -f $res ) {
|
elsif ( -f $res ) {
|
||||||
PTDEBUG && _d('Reading content from file', $res);
|
PTDEBUG && _d('Reading content from file', $res);
|
||||||
@@ -888,13 +958,13 @@ sub _set {
|
|||||||
$content .= $data;
|
$content .= $data;
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
$content = $res->as_json;
|
$content = as_json($res);
|
||||||
}
|
}
|
||||||
|
|
||||||
eval {
|
eval {
|
||||||
$self->_request(
|
$self->_request(
|
||||||
method => $method,
|
method => $method,
|
||||||
url => $link,
|
url => $url,
|
||||||
content => $content,
|
content => $content,
|
||||||
);
|
);
|
||||||
};
|
};
|
||||||
@@ -926,11 +996,12 @@ sub _set {
|
|||||||
sub _request {
|
sub _request {
|
||||||
my ($self, %args) = @_;
|
my ($self, %args) = @_;
|
||||||
|
|
||||||
my @required_args = (
|
have_required_args(\%args, qw(
|
||||||
'method',
|
method
|
||||||
'url',
|
url
|
||||||
);
|
)) or die;
|
||||||
my ($method, $url) = @args{@required_args};
|
my $method = $args{method};
|
||||||
|
my $url = $args{url};
|
||||||
|
|
||||||
my @optional_args = (
|
my @optional_args = (
|
||||||
'content',
|
'content',
|
||||||
@@ -943,10 +1014,10 @@ sub _request {
|
|||||||
if ( uc($method) eq 'DELETE' ) {
|
if ( uc($method) eq 'DELETE' ) {
|
||||||
$self->ua->default_header('Content-Length' => 0);
|
$self->ua->default_header('Content-Length' => 0);
|
||||||
}
|
}
|
||||||
PTDEBUG && _d('Request', $method, $url, $req);
|
PTDEBUG && _d('Request', $method, $url, Dumper($req));
|
||||||
|
|
||||||
my $res = $self->ua->request($req);
|
my $res = $self->ua->request($req);
|
||||||
PTDEBUG && _d('Response', $res);
|
PTDEBUG && _d('Response', Dumper($res));
|
||||||
|
|
||||||
if ( uc($method) eq 'DELETE' ) {
|
if ( uc($method) eq 'DELETE' ) {
|
||||||
$self->ua->default_header('Content-Length' => undef);
|
$self->ua->default_header('Content-Length' => undef);
|
||||||
@@ -974,7 +1045,7 @@ sub update_links {
|
|||||||
$self->links->{$svc}->{$rel} = $link;
|
$self->links->{$svc}->{$rel} = $link;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
PTDEBUG && _d('Updated links', $self->links);
|
PTDEBUG && _d('Updated links', Dumper($self->links));
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1191,49 +1262,6 @@ no Lmo;
|
|||||||
# End Percona::WebAPI::Resource::Run package
|
# End Percona::WebAPI::Resource::Run package
|
||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
|
|
||||||
# ###########################################################################
|
|
||||||
# Percona::WebAPI::Representation package
|
|
||||||
# This package is a copy without comments from the original. The original
|
|
||||||
# with comments and its test file can be found in the Bazaar repository at,
|
|
||||||
# lib/Percona/WebAPI/Representation.pm
|
|
||||||
# t/lib/Percona/WebAPI/Representation.t
|
|
||||||
# See https://launchpad.net/percona-toolkit for more information.
|
|
||||||
# ###########################################################################
|
|
||||||
{
|
|
||||||
package Percona::WebAPI::Representation;
|
|
||||||
|
|
||||||
use JSON;
|
|
||||||
|
|
||||||
sub as_hashref {
|
|
||||||
my $resource = shift;
|
|
||||||
|
|
||||||
my $as_hashref = { %$resource };
|
|
||||||
|
|
||||||
delete $as_hashref->{links};
|
|
||||||
|
|
||||||
return $as_hashref;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub as_json {
|
|
||||||
return encode_json(as_hashref(@_));
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub as_config {
|
|
||||||
my $as_hashref = as_hashref(@_);
|
|
||||||
my $config = join("\n",
|
|
||||||
map { defined $as_hashref->{$_} ? "$_=$as_hashref->{$_}" : "$_" }
|
|
||||||
sort keys %$as_hashref
|
|
||||||
) . "\n";
|
|
||||||
return $config;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
}
|
|
||||||
# ###########################################################################
|
|
||||||
# End Percona::WebAPI::Representation package
|
|
||||||
# ###########################################################################
|
|
||||||
|
|
||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
# Percona::WebAPI::Util package
|
# Percona::WebAPI::Util package
|
||||||
# This package is a copy without comments from the original. The original
|
# This package is a copy without comments from the original. The original
|
||||||
@@ -1251,9 +1279,7 @@ use Percona::WebAPI::Representation;
|
|||||||
|
|
||||||
require Exporter;
|
require Exporter;
|
||||||
our @ISA = qw(Exporter);
|
our @ISA = qw(Exporter);
|
||||||
our %EXPORT_TAGS = ();
|
|
||||||
our @EXPORT_OK = (qw(resource_diff));
|
our @EXPORT_OK = (qw(resource_diff));
|
||||||
our @EXPORT = ();
|
|
||||||
|
|
||||||
sub resource_diff {
|
sub resource_diff {
|
||||||
my ($x, $y) = @_;
|
my ($x, $y) = @_;
|
||||||
@@ -4314,6 +4340,8 @@ use Percona::WebAPI::Resource::Run;
|
|||||||
use Percona::WebAPI::Representation;
|
use Percona::WebAPI::Representation;
|
||||||
use Percona::WebAPI::Util qw(resource_diff);
|
use Percona::WebAPI::Util qw(resource_diff);
|
||||||
|
|
||||||
|
Percona::Toolkit->import(qw(_d Dumper have_required_args));
|
||||||
|
|
||||||
use sigtrap 'handler', \&sig_int, 'normal-signals';
|
use sigtrap 'handler', \&sig_int, 'normal-signals';
|
||||||
|
|
||||||
my $oktorun = 1;
|
my $oktorun = 1;
|
||||||
@@ -4474,7 +4502,7 @@ sub main {
|
|||||||
sub get_api_client {
|
sub get_api_client {
|
||||||
my (%args) = @_;
|
my (%args) = @_;
|
||||||
|
|
||||||
have_required_args(\%args,qw(
|
have_required_args(\%args, qw(
|
||||||
api_key
|
api_key
|
||||||
interval
|
interval
|
||||||
)) or die;
|
)) or die;
|
||||||
@@ -4553,8 +4581,8 @@ sub init_agent {
|
|||||||
: "Creating new agent $agent_id");
|
: "Creating new agent $agent_id");
|
||||||
eval {
|
eval {
|
||||||
$client->$action(
|
$client->$action(
|
||||||
url => $client->links->{agent},
|
url => $client->links->{agents},
|
||||||
content => $agent,
|
resources => $agent,
|
||||||
);
|
);
|
||||||
};
|
};
|
||||||
if ( $EVAL_ERROR ) {
|
if ( $EVAL_ERROR ) {
|
||||||
@@ -4562,7 +4590,8 @@ sub init_agent {
|
|||||||
$interval->();
|
$interval->();
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
_info("Initialized")
|
_info("Initialized");
|
||||||
|
last;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -4685,7 +4714,8 @@ sub _log {
|
|||||||
my ($level, $msg) = @_;
|
my ($level, $msg) = @_;
|
||||||
my ($s, $m, $h, $d, $M) = localtime;
|
my ($s, $m, $h, $d, $M) = localtime;
|
||||||
my $ts = sprintf('%02d-%02dT%02d:%02d:%02d', $M+1, $d, $h, $m, $s);
|
my $ts = sprintf('%02d-%02dT%02d:%02d:%02d', $M+1, $d, $h, $m, $s);
|
||||||
print "$ts $level $msg\n";
|
$msg .= "\n" if $msg !~ m/\n$/;
|
||||||
|
print "$ts $level $msg";
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -4711,7 +4741,7 @@ sub get_uuid {
|
|||||||
|
|
||||||
sub get_versions {
|
sub get_versions {
|
||||||
return {
|
return {
|
||||||
'Perl' => "5.10.1",
|
'Perl' => "5.10.0",
|
||||||
'Percona::WebAPI::Client' => "$Percona::WebAPI::Client::VERSION",
|
'Percona::WebAPI::Client' => "$Percona::WebAPI::Client::VERSION",
|
||||||
};
|
};
|
||||||
}
|
}
|
||||||
|
800
lib/Percona/Test.pm
Normal file
800
lib/Percona/Test.pm
Normal file
@@ -0,0 +1,800 @@
|
|||||||
|
# This program is copyright 2009-2013 Percona Inc.
|
||||||
|
# Feedback and improvements are welcome.
|
||||||
|
#
|
||||||
|
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||||
|
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
||||||
|
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||||
|
#
|
||||||
|
# This program is free software; you can redistribute it and/or modify it under
|
||||||
|
# the terms of the GNU General Public License as published by the Free Software
|
||||||
|
# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
|
||||||
|
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
|
||||||
|
# licenses.
|
||||||
|
#
|
||||||
|
# You should have received a copy of the GNU General Public License along with
|
||||||
|
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
|
||||||
|
# Place, Suite 330, Boston, MA 02111-1307 USA.
|
||||||
|
# ###########################################################################
|
||||||
|
# Percona::Test package
|
||||||
|
# ###########################################################################
|
||||||
|
{
|
||||||
|
# Package: Percona::Test
|
||||||
|
# PerconaTest is a collection of helper-subs for Percona Toolkit tests.
|
||||||
|
# Any file arguments (like no_diff() $expected_output) are relative to
|
||||||
|
# PERCONA_TOOLKIT_BRANCH. So passing "commont/t/samples/foo" means
|
||||||
|
# "PERCONA_TOOLKIT_BRANCH/common/t/samples/foo". Do not BAIL_OUT() because
|
||||||
|
# this terminates the *entire* test process; die instead. All
|
||||||
|
# subs are exported by default, so is the variable $trunk, so there's
|
||||||
|
# no need to import() in the test scripts.
|
||||||
|
package Percona::Test;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings FATAL => 'all';
|
||||||
|
use English qw(-no_match_vars);
|
||||||
|
use constant PTDEVDEBUG => $ENV{PTDEVDEBUG} || 0;
|
||||||
|
|
||||||
|
use Data::Dumper;
|
||||||
|
$Data::Dumper::Indent = 1;
|
||||||
|
$Data::Dumper::Sortkeys = 1;
|
||||||
|
$Data::Dumper::Quotekeys = 0;
|
||||||
|
|
||||||
|
use Test::More;
|
||||||
|
use Time::HiRes qw(sleep time);
|
||||||
|
use File::Temp qw(tempfile);
|
||||||
|
use POSIX qw(signal_h);
|
||||||
|
|
||||||
|
require Exporter;
|
||||||
|
our @ISA = qw(Exporter);
|
||||||
|
our %EXPORT_TAGS = ();
|
||||||
|
our @EXPORT_OK = qw();
|
||||||
|
our @EXPORT = qw(
|
||||||
|
output
|
||||||
|
full_output
|
||||||
|
load_data
|
||||||
|
load_file
|
||||||
|
slurp_file
|
||||||
|
parse_file
|
||||||
|
wait_until
|
||||||
|
wait_for
|
||||||
|
wait_until_slave_running
|
||||||
|
wait_until_no_lag
|
||||||
|
test_log_parser
|
||||||
|
test_protocol_parser
|
||||||
|
test_packet_parser
|
||||||
|
no_diff
|
||||||
|
throws_ok
|
||||||
|
remove_traces
|
||||||
|
test_bash_tool
|
||||||
|
verify_test_data_integrity
|
||||||
|
$trunk
|
||||||
|
$dsn_opts
|
||||||
|
$sandbox_version
|
||||||
|
$can_load_data
|
||||||
|
);
|
||||||
|
|
||||||
|
our $trunk = $ENV{PERCONA_TOOLKIT_BRANCH};
|
||||||
|
|
||||||
|
our $sandbox_version = '';
|
||||||
|
eval {
|
||||||
|
chomp(my $v = `$trunk/sandbox/test-env version 2>/dev/null`);
|
||||||
|
$sandbox_version = $v if $v;
|
||||||
|
};
|
||||||
|
|
||||||
|
our $can_load_data = can_load_data();
|
||||||
|
|
||||||
|
our $dsn_opts = [
|
||||||
|
{
|
||||||
|
key => 'A',
|
||||||
|
desc => 'Default character set',
|
||||||
|
dsn => 'charset',
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
{
|
||||||
|
key => 'D',
|
||||||
|
desc => 'Database to use',
|
||||||
|
dsn => 'database',
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
{
|
||||||
|
key => 'F',
|
||||||
|
desc => 'Only read default options from the given file',
|
||||||
|
dsn => 'mysql_read_default_file',
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
{
|
||||||
|
key => 'h',
|
||||||
|
desc => 'Connect to host',
|
||||||
|
dsn => 'host',
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
{
|
||||||
|
key => 'p',
|
||||||
|
desc => 'Password to use when connecting',
|
||||||
|
dsn => 'password',
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
{
|
||||||
|
key => 'P',
|
||||||
|
desc => 'Port number to use for connection',
|
||||||
|
dsn => 'port',
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
{
|
||||||
|
key => 'S',
|
||||||
|
desc => 'Socket file to use for connection',
|
||||||
|
dsn => 'mysql_socket',
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
{
|
||||||
|
key => 't',
|
||||||
|
desc => 'Table',
|
||||||
|
dsn => undef,
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
{
|
||||||
|
key => 'u',
|
||||||
|
desc => 'User for login if not current user',
|
||||||
|
dsn => 'user',
|
||||||
|
copy => 1,
|
||||||
|
},
|
||||||
|
];
|
||||||
|
|
||||||
|
# Runs code, captures and returns its output.
|
||||||
|
# Optional arguments:
|
||||||
|
# * file scalar: capture output to this file (default none)
|
||||||
|
# * stderr scalar: capture STDERR (default no)
|
||||||
|
# * die scalar: die if code dies (default no)
|
||||||
|
# * trf coderef: pass output to this coderef (default none)
|
||||||
|
sub output {
|
||||||
|
my ( $code, %args ) = @_;
|
||||||
|
die "I need a code argument" unless $code;
|
||||||
|
my ($file, $stderr, $die, $trf) = @args{qw(file stderr die trf)};
|
||||||
|
|
||||||
|
my $output = '';
|
||||||
|
{
|
||||||
|
if ( $file ) {
|
||||||
|
open *output_fh, '>', $file
|
||||||
|
or die "Cannot open file $file: $OS_ERROR";
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
open *output_fh, '>', \$output
|
||||||
|
or die "Cannot capture output to variable: $OS_ERROR";
|
||||||
|
}
|
||||||
|
local *STDOUT = *output_fh;
|
||||||
|
|
||||||
|
# If capturing STDERR we must dynamically scope (local) STDERR
|
||||||
|
# in the outer scope of the sub. If we did,
|
||||||
|
# if ( $args{stderr} ) { local *STDERR; ... }
|
||||||
|
# then STDERR would revert to its original value outside the if
|
||||||
|
# block.
|
||||||
|
local *STDERR if $args{stderr}; # do in outer scope of this sub
|
||||||
|
*STDERR = *STDOUT if $args{stderr};
|
||||||
|
|
||||||
|
eval { $code->() };
|
||||||
|
if ( $EVAL_ERROR ) {
|
||||||
|
die $EVAL_ERROR if $die;
|
||||||
|
warn $EVAL_ERROR;
|
||||||
|
}
|
||||||
|
|
||||||
|
close *output_fh;
|
||||||
|
}
|
||||||
|
|
||||||
|
select STDOUT;
|
||||||
|
|
||||||
|
# Possible transform output before returning it. This doesn't work
|
||||||
|
# if output was captured to a file.
|
||||||
|
$output = $trf->($output) if $trf;
|
||||||
|
|
||||||
|
return $output;
|
||||||
|
}
|
||||||
|
|
||||||
|
# Load data from file and removes spaces. Used to load tcpdump dumps.
|
||||||
|
sub load_data {
|
||||||
|
my ( $file ) = @_;
|
||||||
|
$file = "$trunk/$file";
|
||||||
|
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
|
||||||
|
my $contents = do { local $/ = undef; <$fh> };
|
||||||
|
close $fh;
|
||||||
|
(my $data = join('', $contents =~ m/(.*)/g)) =~ s/\s+//g;
|
||||||
|
return $data;
|
||||||
|
}
|
||||||
|
|
||||||
|
# Slurp file and return its entire contents.
|
||||||
|
sub load_file {
|
||||||
|
my ( $file, %args ) = @_;
|
||||||
|
$file = "$trunk/$file";
|
||||||
|
my $contents = slurp_file($file);
|
||||||
|
chomp $contents if $args{chomp_contents};
|
||||||
|
return $contents;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub slurp_file {
|
||||||
|
my ($file) = @_;
|
||||||
|
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
|
||||||
|
my $contents = do { local $/ = undef; <$fh> };
|
||||||
|
close $fh;
|
||||||
|
return $contents;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub parse_file {
|
||||||
|
my ( $file, $p, $ea ) = @_;
|
||||||
|
$file = "$trunk/$file";
|
||||||
|
my @e;
|
||||||
|
eval {
|
||||||
|
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
|
||||||
|
my %args = (
|
||||||
|
next_event => sub { return <$fh>; },
|
||||||
|
tell => sub { return tell $fh; },
|
||||||
|
fh => $fh,
|
||||||
|
);
|
||||||
|
while ( my $e = $p->parse_event(%args) ) {
|
||||||
|
push @e, $e;
|
||||||
|
$ea->aggregate($e) if $ea;
|
||||||
|
}
|
||||||
|
close $fh;
|
||||||
|
};
|
||||||
|
die $EVAL_ERROR if $EVAL_ERROR;
|
||||||
|
return \@e;
|
||||||
|
}
|
||||||
|
|
||||||
|
# Wait until code returns true.
|
||||||
|
sub wait_until {
|
||||||
|
my ( $code, $t, $max_t ) = @_;
|
||||||
|
$t ||= .20;
|
||||||
|
$max_t ||= 30;
|
||||||
|
|
||||||
|
my $slept = 0;
|
||||||
|
while ( $slept <= $max_t ) {
|
||||||
|
return 1 if $code->();
|
||||||
|
PTDEVDEBUG && _d('wait_until sleeping', $t);
|
||||||
|
sleep $t;
|
||||||
|
$slept += $t;
|
||||||
|
PTDEVDEBUG && _d('wait_until slept', $slept, 'of', $max_t);
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
# Wait t seconds for code to return.
|
||||||
|
sub wait_for {
|
||||||
|
my ( $code, $t ) = @_;
|
||||||
|
$t ||= 0;
|
||||||
|
my $mask = POSIX::SigSet->new(&POSIX::SIGALRM);
|
||||||
|
my $action = POSIX::SigAction->new(
|
||||||
|
sub { die },
|
||||||
|
$mask,
|
||||||
|
);
|
||||||
|
my $oldaction = POSIX::SigAction->new();
|
||||||
|
sigaction(&POSIX::SIGALRM, $action, $oldaction);
|
||||||
|
eval {
|
||||||
|
alarm $t;
|
||||||
|
$code->();
|
||||||
|
alarm 0;
|
||||||
|
};
|
||||||
|
if ( $EVAL_ERROR ) {
|
||||||
|
# alarm was raised
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub wait_for_table {
|
||||||
|
my ($dbh, $tbl, $where) = @_;
|
||||||
|
my $sql = "SELECT 1 FROM $tbl" . ($where ? " WHERE $where LIMIT 1" : "");
|
||||||
|
return wait_until(
|
||||||
|
sub {
|
||||||
|
my $r;
|
||||||
|
eval { $r = $dbh->selectrow_arrayref($sql); };
|
||||||
|
if ( $EVAL_ERROR ) {
|
||||||
|
PTDEVDEBUG && _d('Waiting on', $dbh, 'for table', $tbl,
|
||||||
|
'error:', $EVAL_ERROR);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
if ( $where && (!$r || !scalar @$r) ) {
|
||||||
|
PTDEVDEBUG && _d('Waiting on', $dbh, 'for table', $tbl,
|
||||||
|
'WHERE', $where);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
},
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub wait_for_files {
|
||||||
|
my (@files) = @_;
|
||||||
|
return wait_until(
|
||||||
|
sub {
|
||||||
|
foreach my $file (@files) {
|
||||||
|
if ( ! -f $file ) {
|
||||||
|
PTDEVDEBUG && _d('Waiting for file', $file);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
},
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub wait_for_sh {
|
||||||
|
my ($cmd) = @_;
|
||||||
|
return wait_until(
|
||||||
|
sub {
|
||||||
|
my $retval = system("$cmd 2>/dev/null");
|
||||||
|
return $retval >> 8 == 0 ? 1 : 0;
|
||||||
|
}
|
||||||
|
);
|
||||||
|
};
|
||||||
|
|
||||||
|
sub not_running {
|
||||||
|
my ($cmd) = @_;
|
||||||
|
PTDEVDEBUG && _d('Wait until not running:', $cmd);
|
||||||
|
return wait_until(
|
||||||
|
sub {
|
||||||
|
my $output = `ps x | grep -v grep | grep "$cmd"`;
|
||||||
|
PTDEVDEBUG && _d($output);
|
||||||
|
return 1 unless $output;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _read {
|
||||||
|
my ( $fh ) = @_;
|
||||||
|
return <$fh>;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub test_log_parser {
|
||||||
|
my ( %args ) = @_;
|
||||||
|
foreach my $arg ( qw(parser file) ) {
|
||||||
|
die "I need a $arg argument" unless $args{$arg};
|
||||||
|
}
|
||||||
|
my $p = $args{parser};
|
||||||
|
|
||||||
|
# Make sure caller isn't giving us something we don't understand.
|
||||||
|
# We could ignore it, but then caller might not get the results
|
||||||
|
# they expected.
|
||||||
|
map { die "What is $_ for?"; }
|
||||||
|
grep { $_ !~ m/^(?:parser|misc|file|result|num_events|oktorun)$/ }
|
||||||
|
keys %args;
|
||||||
|
|
||||||
|
my $file = "$trunk/$args{file}";
|
||||||
|
my @e;
|
||||||
|
eval {
|
||||||
|
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
|
||||||
|
my %parser_args = (
|
||||||
|
next_event => sub { return _read($fh); },
|
||||||
|
tell => sub { return tell($fh); },
|
||||||
|
fh => $fh,
|
||||||
|
misc => $args{misc},
|
||||||
|
oktorun => $args{oktorun},
|
||||||
|
);
|
||||||
|
while ( my $e = $p->parse_event(%parser_args) ) {
|
||||||
|
push @e, $e;
|
||||||
|
}
|
||||||
|
close $fh;
|
||||||
|
};
|
||||||
|
|
||||||
|
my ($base_file_name) = $args{file} =~ m/([^\/]+)$/;
|
||||||
|
is(
|
||||||
|
$EVAL_ERROR,
|
||||||
|
'',
|
||||||
|
"$base_file_name: no errors"
|
||||||
|
);
|
||||||
|
|
||||||
|
if ( defined $args{result} ) {
|
||||||
|
is_deeply(
|
||||||
|
\@e,
|
||||||
|
$args{result},
|
||||||
|
"$base_file_name: results"
|
||||||
|
) or diag(Dumper(\@e));
|
||||||
|
}
|
||||||
|
|
||||||
|
if ( defined $args{num_events} ) {
|
||||||
|
is(
|
||||||
|
scalar @e,
|
||||||
|
$args{num_events},
|
||||||
|
"$base_file_name: $args{num_events} events"
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
return \@e;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub test_protocol_parser {
|
||||||
|
my ( %args ) = @_;
|
||||||
|
foreach my $arg ( qw(parser protocol file) ) {
|
||||||
|
die "I need a $arg argument" unless $args{$arg};
|
||||||
|
}
|
||||||
|
my $parser = $args{parser};
|
||||||
|
my $protocol = $args{protocol};
|
||||||
|
|
||||||
|
# Make sure caller isn't giving us something we don't understand.
|
||||||
|
# We could ignore it, but then caller might not get the results
|
||||||
|
# they expected.
|
||||||
|
map { die "What is $_ for?"; }
|
||||||
|
grep { $_ !~ m/^(?:parser|protocol|misc|file|result|num_events|desc)$/ }
|
||||||
|
keys %args;
|
||||||
|
|
||||||
|
my $file = "$trunk/$args{file}";
|
||||||
|
my @e;
|
||||||
|
eval {
|
||||||
|
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
|
||||||
|
my %parser_args = (
|
||||||
|
next_event => sub { return _read($fh); },
|
||||||
|
tell => sub { return tell($fh); },
|
||||||
|
misc => $args{misc},
|
||||||
|
);
|
||||||
|
while ( my $p = $parser->parse_event(%parser_args) ) {
|
||||||
|
my $e = $protocol->parse_event(%parser_args, event => $p);
|
||||||
|
push @e, $e if $e;
|
||||||
|
}
|
||||||
|
close $fh;
|
||||||
|
};
|
||||||
|
|
||||||
|
my ($base_file_name) = $args{file} =~ m/([^\/]+)$/;
|
||||||
|
is(
|
||||||
|
$EVAL_ERROR,
|
||||||
|
'',
|
||||||
|
"$base_file_name: no errors"
|
||||||
|
);
|
||||||
|
|
||||||
|
if ( defined $args{result} ) {
|
||||||
|
is_deeply(
|
||||||
|
\@e,
|
||||||
|
$args{result},
|
||||||
|
"$base_file_name: " . ($args{desc} || "results")
|
||||||
|
) or diag(Dumper(\@e));
|
||||||
|
}
|
||||||
|
|
||||||
|
if ( defined $args{num_events} ) {
|
||||||
|
is(
|
||||||
|
scalar @e,
|
||||||
|
$args{num_events},
|
||||||
|
"$base_file_name: $args{num_events} events"
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
return \@e;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub test_packet_parser {
|
||||||
|
my ( %args ) = @_;
|
||||||
|
foreach my $arg ( qw(parser file) ) {
|
||||||
|
die "I need a $arg argument" unless $args{$arg};
|
||||||
|
}
|
||||||
|
my $parser = $args{parser};
|
||||||
|
|
||||||
|
# Make sure caller isn't giving us something we don't understand.
|
||||||
|
# We could ignore it, but then caller might not get the results
|
||||||
|
# they expected.
|
||||||
|
map { die "What is $_ for?"; }
|
||||||
|
grep { $_ !~ m/^(?:parser|misc|file|result|desc|oktorun)$/ }
|
||||||
|
keys %args;
|
||||||
|
|
||||||
|
my $file = "$trunk/$args{file}";
|
||||||
|
my @packets;
|
||||||
|
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
|
||||||
|
my %parser_args = (
|
||||||
|
next_event => sub { return _read($fh); },
|
||||||
|
tell => sub { return tell($fh); },
|
||||||
|
misc => $args{misc},
|
||||||
|
oktorun => $args{oktorun},
|
||||||
|
);
|
||||||
|
while ( my $packet = $parser->parse_event(%parser_args) ) {
|
||||||
|
push @packets, $packet;
|
||||||
|
}
|
||||||
|
|
||||||
|
# raw_packet is the actual dump text from the file. It's used
|
||||||
|
# in MySQLProtocolParser but I don't think we need to double-check
|
||||||
|
# it here. It will make the results very long.
|
||||||
|
foreach my $packet ( @packets ) {
|
||||||
|
delete $packet->{raw_packet};
|
||||||
|
}
|
||||||
|
|
||||||
|
if ( !is_deeply(
|
||||||
|
\@packets,
|
||||||
|
$args{result},
|
||||||
|
"$args{file}" . ($args{desc} ? ": $args{desc}" : '')
|
||||||
|
) ) {
|
||||||
|
diag(Dumper(\@packets));
|
||||||
|
}
|
||||||
|
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
# no_diff() compares the STDOUT output of a cmd or code to expected output.
|
||||||
|
# Returns true if there are no differences between the two outputs,
|
||||||
|
# else returns false. Dies if the cmd/code dies. Does not capture STDERR.
|
||||||
|
# Args:
|
||||||
|
# * cmd scalar or coderef: if cmd is a scalar then the
|
||||||
|
# cmd is ran via the shell. if it's a coderef then
|
||||||
|
# the code is ran. the latter is preferred because
|
||||||
|
# it generates test coverage.
|
||||||
|
# * expected_output scalar: file name relative to PERCONA_TOOLKIT_BRANCH
|
||||||
|
# * args hash: (optional) may include
|
||||||
|
# update_sample overwrite expected_output with cmd/code output
|
||||||
|
# keep_output keep last cmd/code output file
|
||||||
|
# transform_result transform the code to be compared but do not
|
||||||
|
# reflect these changes on the original file
|
||||||
|
# if update_sample is passed in
|
||||||
|
# transform_sample similar to the above, but with the sample
|
||||||
|
# file
|
||||||
|
# * trf transform cmd/code output before diff
|
||||||
|
# The sub dies if cmd or code dies. STDERR is not captured.
|
||||||
|
sub no_diff {
|
||||||
|
my ( $cmd, $expected_output, %args ) = @_;
|
||||||
|
die "I need a cmd argument" unless $cmd;
|
||||||
|
die "I need an expected_output argument" unless $expected_output;
|
||||||
|
|
||||||
|
die "$expected_output does not exist" unless -f "$trunk/$expected_output";
|
||||||
|
$expected_output = "$trunk/$expected_output";
|
||||||
|
|
||||||
|
my $tmp_file = '/tmp/percona-toolkit-test-output.txt';
|
||||||
|
my $tmp_file_orig = '/tmp/percona-toolkit-test-output-original.txt';
|
||||||
|
|
||||||
|
if ( my $sed_args = $args{sed_out} ) {
|
||||||
|
`cat $expected_output | sed $sed_args > /tmp/pt-test-outfile-trf`;
|
||||||
|
$expected_output = "/tmp/pt-test-outfile-trf";
|
||||||
|
}
|
||||||
|
|
||||||
|
# Determine cmd type and run it.
|
||||||
|
if ( ref $cmd eq 'CODE' ) {
|
||||||
|
output($cmd, file => $tmp_file);
|
||||||
|
}
|
||||||
|
elsif ( $args{cmd_output} ) {
|
||||||
|
# Copy cmd output to tmp file so we don't with the original.
|
||||||
|
open my $tmp_fh, '>', $tmp_file or die "Cannot open $tmp_file: $OS_ERROR";
|
||||||
|
print $tmp_fh $cmd;
|
||||||
|
close $tmp_fh;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
`$cmd > $tmp_file`;
|
||||||
|
}
|
||||||
|
|
||||||
|
# Do optional arg stuff.
|
||||||
|
`cp $tmp_file $tmp_file_orig`;
|
||||||
|
if ( my $trf = $args{trf} ) {
|
||||||
|
`$trf $tmp_file_orig > $tmp_file`;
|
||||||
|
}
|
||||||
|
if ( my $post_pipe = $args{post_pipe} ) {
|
||||||
|
`cat $tmp_file | $post_pipe > $tmp_file-2`;
|
||||||
|
`mv $tmp_file-2 $tmp_file`;
|
||||||
|
}
|
||||||
|
if ( my $sed_args = $args{sed} ) {
|
||||||
|
foreach my $sed_args ( @{$args{sed}} ) {
|
||||||
|
`cat $tmp_file | sed $sed_args > $tmp_file-2`;
|
||||||
|
`mv $tmp_file-2 $tmp_file`;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if ( defined(my $sort_args = $args{sort}) ) {
|
||||||
|
`cat $tmp_file | sort $sort_args > $tmp_file-2`;
|
||||||
|
`mv $tmp_file-2 $tmp_file`;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $res_file = $tmp_file;
|
||||||
|
if ( $args{transform_result} ) {
|
||||||
|
(undef, $res_file) = tempfile();
|
||||||
|
output(
|
||||||
|
sub { $args{transform_result}->($tmp_file) },
|
||||||
|
file => $res_file,
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
my $cmp_file = $expected_output;
|
||||||
|
if ( $args{transform_sample} ) {
|
||||||
|
(undef, $cmp_file) = tempfile();
|
||||||
|
output(
|
||||||
|
sub { $args{transform_sample}->($expected_output) },
|
||||||
|
file => $cmp_file,
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
# diff the outputs.
|
||||||
|
my $out = `diff $res_file $cmp_file`;
|
||||||
|
my $retval = $?;
|
||||||
|
|
||||||
|
# diff returns 0 if there were no differences,
|
||||||
|
# so !0 = 1 = no diff in our testing parlance.
|
||||||
|
$retval = $retval >> 8;
|
||||||
|
|
||||||
|
if ( $retval ) {
|
||||||
|
diag($out);
|
||||||
|
if ( $ENV{UPDATE_SAMPLES} || $args{update_sample} ) {
|
||||||
|
`cat $tmp_file > $expected_output`;
|
||||||
|
diag("Updated $expected_output");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Remove our tmp files.
|
||||||
|
`rm -f $tmp_file $tmp_file_orig /tmp/pt-test-outfile-trf >/dev/null 2>&1`
|
||||||
|
unless $ENV{KEEP_OUTPUT} || $args{keep_output};
|
||||||
|
|
||||||
|
if ( $res_file ne $tmp_file ) {
|
||||||
|
1 while unlink $res_file;
|
||||||
|
}
|
||||||
|
|
||||||
|
if ( $cmp_file ne $expected_output ) {
|
||||||
|
1 while unlink $cmp_file;
|
||||||
|
}
|
||||||
|
|
||||||
|
return !$retval;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub throws_ok {
|
||||||
|
my ( $code, $pat, $msg ) = @_;
|
||||||
|
eval { $code->(); };
|
||||||
|
like ( $EVAL_ERROR, $pat, $msg );
|
||||||
|
}
|
||||||
|
|
||||||
|
# Remove /*percona-toolkit ...*/ trace comments from the given SQL statement(s).
|
||||||
|
# Traces are added in ChangeHandler::process_rows().
|
||||||
|
sub remove_traces {
|
||||||
|
my ( $sql ) = @_;
|
||||||
|
my $trace_pat = qr/ \/\*percona-toolkit .+?\*\//;
|
||||||
|
if ( ref $sql && ref $sql eq 'ARRAY' ) {
|
||||||
|
map { $_ =~ s/$trace_pat//gm } @$sql;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$sql =~ s/$trace_pat//gm;
|
||||||
|
}
|
||||||
|
return $sql;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub test_bash_tool {
|
||||||
|
my ( $tool ) = @_;
|
||||||
|
die "I need a tool argument" unless $tool;
|
||||||
|
my $outfile = "/tmp/$tool-test-results.txt";
|
||||||
|
`rm -rf $outfile >/dev/null`;
|
||||||
|
`$trunk/util/test-bash-tool $tool > $outfile`;
|
||||||
|
print `cat $outfile`;
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
my %checksum_result_col = (
|
||||||
|
ts => 0,
|
||||||
|
errors => 1,
|
||||||
|
diffs => 2,
|
||||||
|
rows => 3,
|
||||||
|
chunks => 4,
|
||||||
|
skipped => 5,
|
||||||
|
time => 6,
|
||||||
|
table => 7,
|
||||||
|
);
|
||||||
|
sub count_checksum_results {
|
||||||
|
my ($output, $column, $table) = @_;
|
||||||
|
|
||||||
|
my (@res) = map {
|
||||||
|
my $line = $_;
|
||||||
|
my (@cols) = $line =~ m/(\S+)/g;
|
||||||
|
\@cols;
|
||||||
|
}
|
||||||
|
grep {
|
||||||
|
my $line = $_;
|
||||||
|
if ( !$table ) {
|
||||||
|
$line;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$line =~ m/$table$/m ? $line : '';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
grep { m/^\d+\-\d+T\d\d:\d\d:\d\d\s+\d+/ } split /\n/, $output;
|
||||||
|
my $colno = $checksum_result_col{lc $column};
|
||||||
|
die "Invalid checksum result column: $column" unless defined $colno;
|
||||||
|
my $total = 0;
|
||||||
|
map { $total += $_->[$colno] } @res;
|
||||||
|
return $total;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub normalize_checksum_results {
|
||||||
|
my ($output) = @_;
|
||||||
|
my $tmp_file = "/tmp/test-checksum-results-output";
|
||||||
|
open my $fh, ">", $tmp_file or die "Cannot open $tmp_file: $OS_ERROR";
|
||||||
|
printf $fh $output;
|
||||||
|
close $fh;
|
||||||
|
my $normal_output = `cat $tmp_file | awk '/^[0-9 ]/ {print \$2 " " \$3 " " \$4 " " \$5 " " \$6 " " \$8} /^[A-Z]/ {print \$0}'`;
|
||||||
|
`rm $tmp_file >/dev/null`;
|
||||||
|
return $normal_output;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_master_binlog_pos {
|
||||||
|
my ($dbh) = @_;
|
||||||
|
my $sql = "SHOW MASTER STATUS";
|
||||||
|
my $ms = $dbh->selectrow_hashref($sql);
|
||||||
|
return $ms->{position};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_slave_pos_relative_to_master {
|
||||||
|
my ($dbh) = @_;
|
||||||
|
my $sql = "SHOW SLAVE STATUS";
|
||||||
|
my $ss = $dbh->selectrow_hashref($sql);
|
||||||
|
return $ss->{exec_master_log_pos};
|
||||||
|
}
|
||||||
|
|
||||||
|
# Like output(), but forks a process to execute the coderef.
|
||||||
|
# This is because otherwise, errors thrown during cleanup
|
||||||
|
# would be skipped.
|
||||||
|
sub full_output {
|
||||||
|
my ( $code, %args ) = @_;
|
||||||
|
die "I need a code argument" unless $code;
|
||||||
|
|
||||||
|
local (*STDOUT, *STDERR);
|
||||||
|
require IO::File;
|
||||||
|
|
||||||
|
my (undef, $file) = tempfile();
|
||||||
|
open *STDOUT, '>', $file
|
||||||
|
or die "Cannot open file $file: $OS_ERROR";
|
||||||
|
*STDOUT->autoflush(1);
|
||||||
|
|
||||||
|
my (undef, $file2) = tempfile();
|
||||||
|
open *STDERR, '>', $file2
|
||||||
|
or die "Cannot open file $file2: $OS_ERROR";
|
||||||
|
*STDERR->autoflush(1);
|
||||||
|
|
||||||
|
my $status;
|
||||||
|
if (my $pid = fork) {
|
||||||
|
if ( my $t = $args{wait_for} ) {
|
||||||
|
# Wait for t seconds then kill the child.
|
||||||
|
sleep $t;
|
||||||
|
my $tries = 3;
|
||||||
|
# Most tools require 2 interrupts to make them stop.
|
||||||
|
while ( kill(0, $pid) && $tries-- ) {
|
||||||
|
kill SIGTERM, $pid;
|
||||||
|
sleep 0.10;
|
||||||
|
}
|
||||||
|
# Child didn't respond to SIGTERM? Then kill -9 it.
|
||||||
|
kill SIGKILL, $pid if kill(0, $pid);
|
||||||
|
sleep 0.25;
|
||||||
|
}
|
||||||
|
waitpid($pid, 0);
|
||||||
|
$status = $? >> 8;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
exit $code->();
|
||||||
|
}
|
||||||
|
close $_ or die "Cannot close $_: $OS_ERROR" for qw(STDOUT STDERR);
|
||||||
|
my $output = slurp_file($file) . slurp_file($file2);
|
||||||
|
|
||||||
|
unlink $file;
|
||||||
|
unlink $file2;
|
||||||
|
|
||||||
|
return ($output, $status);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub tables_used {
|
||||||
|
my ($file) = @_;
|
||||||
|
local $INPUT_RECORD_SEPARATOR = '';
|
||||||
|
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
|
||||||
|
my %tables;
|
||||||
|
while ( defined(my $chunk = <$fh>) ) {
|
||||||
|
map {
|
||||||
|
my $db_tbl = $_;
|
||||||
|
$db_tbl =~ s/^\s*`?//; # strip leading space and `
|
||||||
|
$db_tbl =~ s/\s*`?$//; # strip trailing space and `
|
||||||
|
$db_tbl =~ s/`\.`/./; # strip inner `.`
|
||||||
|
$tables{$db_tbl} = 1;
|
||||||
|
}
|
||||||
|
grep {
|
||||||
|
m/(?:\w\.\w|`\.`)/ # only db.tbl, not just db
|
||||||
|
}
|
||||||
|
$chunk =~ m/(?:FROM|INTO|UPDATE)\s+(\S+)/gi;
|
||||||
|
}
|
||||||
|
return [ sort keys %tables ];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub can_load_data {
|
||||||
|
my $output = `/tmp/12345/use -e "SELECT * FROM percona_test.load_data" 2>/dev/null`;
|
||||||
|
return ($output || '') =~ /1/;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _d {
|
||||||
|
my ($package, undef, $line) = caller 0;
|
||||||
|
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
|
||||||
|
map { defined $_ ? $_ : 'undef' }
|
||||||
|
@_;
|
||||||
|
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
}
|
||||||
|
# ###########################################################################
|
||||||
|
# End PerconaTest package
|
||||||
|
# ###########################################################################
|
62
lib/Percona/Test/Mock/UserAgent.pm
Normal file
62
lib/Percona/Test/Mock/UserAgent.pm
Normal file
@@ -0,0 +1,62 @@
|
|||||||
|
# This program is copyright 2012-2013 Percona Inc.
|
||||||
|
# Feedback and improvements are welcome.
|
||||||
|
#
|
||||||
|
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||||
|
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
||||||
|
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||||
|
#
|
||||||
|
# This program is free software; you can redistribute it and/or modify it under
|
||||||
|
# the terms of the GNU General Public License as published by the Free Software
|
||||||
|
# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
|
||||||
|
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
|
||||||
|
# licenses.
|
||||||
|
#
|
||||||
|
# You should have received a copy of the GNU General Public License along with
|
||||||
|
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
|
||||||
|
# Place, Suite 330, Boston, MA 02111-1307 USA.
|
||||||
|
# ###########################################################################
|
||||||
|
# Percona::Test::Mock::UserAgent package
|
||||||
|
# ###########################################################################
|
||||||
|
{
|
||||||
|
package Percona::Test::Mock::UserAgent;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my ($class, %args) = @_;
|
||||||
|
my $self = {
|
||||||
|
encode => $args{encode} || sub { return $_[0] },
|
||||||
|
decode => $args{decode} || sub { return $_[0] },
|
||||||
|
responses => {
|
||||||
|
get => [],
|
||||||
|
post => [],
|
||||||
|
put => [],
|
||||||
|
},
|
||||||
|
content => {
|
||||||
|
post => undef,
|
||||||
|
put => undef,
|
||||||
|
},
|
||||||
|
};
|
||||||
|
return bless $self, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub request {
|
||||||
|
my ($self, $req) = @_;
|
||||||
|
my $type = lc($req->method);
|
||||||
|
if ( $type eq 'post' || $type eq 'put' ) {
|
||||||
|
$self->{content}->{$type} = $req->content;
|
||||||
|
}
|
||||||
|
my $r = shift @{$self->{responses}->{$type}};
|
||||||
|
my $c = $self->{encode}->($r->{content});
|
||||||
|
my $res = HTTP::Response->new(
|
||||||
|
$r->{code} || 200,
|
||||||
|
'',
|
||||||
|
HTTP::Headers->new,
|
||||||
|
$c,
|
||||||
|
);
|
||||||
|
return $res;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
}
|
||||||
|
# ###########################################################################
|
||||||
|
# End Percona::Test::Mock::UserAgent package
|
||||||
|
# ###########################################################################
|
@@ -17,7 +17,6 @@
|
|||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
# Percona::Toolkit package
|
# Percona::Toolkit package
|
||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
{
|
|
||||||
package Percona::Toolkit;
|
package Percona::Toolkit;
|
||||||
|
|
||||||
our $VERSION = '3.0.0';
|
our $VERSION = '3.0.0';
|
||||||
@@ -29,12 +28,10 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|||||||
|
|
||||||
use Carp qw(carp cluck);
|
use Carp qw(carp cluck);
|
||||||
use Data::Dumper qw();
|
use Data::Dumper qw();
|
||||||
$Data::Dumper::Indent = 1;
|
|
||||||
$Data::Dumper::Sortkeys = 1;
|
|
||||||
$Data::Dumper::Quotekeys = 0;
|
|
||||||
|
|
||||||
use Exporter 'import';
|
require Exporter;
|
||||||
our @EXPORT = qw(
|
our @ISA = qw(Exporter);
|
||||||
|
our @EXPORT_OK = qw(
|
||||||
have_required_args
|
have_required_args
|
||||||
Dumper
|
Dumper
|
||||||
_d
|
_d
|
||||||
@@ -54,6 +51,9 @@ sub have_required_args {
|
|||||||
}
|
}
|
||||||
|
|
||||||
sub Dumper {
|
sub Dumper {
|
||||||
|
local $Data::Dumper::Indent = 1;
|
||||||
|
local $Data::Dumper::Sortkeys = 1;
|
||||||
|
local $Data::Dumper::Quotekeys = 0;
|
||||||
Data::Dumper::Dumper(@_);
|
Data::Dumper::Dumper(@_);
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -66,7 +66,6 @@ sub _d {
|
|||||||
}
|
}
|
||||||
|
|
||||||
1;
|
1;
|
||||||
}
|
|
||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
# End Percona::Toolkit package
|
# End Percona::Toolkit package
|
||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
|
@@ -34,8 +34,12 @@ use English qw(-no_match_vars);
|
|||||||
|
|
||||||
use Lmo;
|
use Lmo;
|
||||||
use Percona::Toolkit;
|
use Percona::Toolkit;
|
||||||
|
use Percona::WebAPI::Representation;
|
||||||
use Percona::WebAPI::Exception::Request;
|
use Percona::WebAPI::Exception::Request;
|
||||||
|
|
||||||
|
Percona::WebAPI::Representation->import(qw(as_json));
|
||||||
|
Percona::Toolkit->import(qw(_d Dumper have_required_args));
|
||||||
|
|
||||||
has 'api_key' => (
|
has 'api_key' => (
|
||||||
is => 'ro',
|
is => 'ro',
|
||||||
isa => 'Str',
|
isa => 'Str',
|
||||||
@@ -45,8 +49,8 @@ has 'api_key' => (
|
|||||||
has 'base_url' => (
|
has 'base_url' => (
|
||||||
is => 'rw',
|
is => 'rw',
|
||||||
isa => 'Str',
|
isa => 'Str',
|
||||||
default => 'https://api.tools.percona.com',
|
default => sub { return 'https://api.tools.percona.com' },
|
||||||
required => 1,
|
required => 0,
|
||||||
);
|
);
|
||||||
|
|
||||||
has 'links' => (
|
has 'links' => (
|
||||||
@@ -58,7 +62,7 @@ has 'links' => (
|
|||||||
|
|
||||||
has 'ua' => (
|
has 'ua' => (
|
||||||
is => 'rw',
|
is => 'rw',
|
||||||
isa => 'LWP::UserAgent',
|
isa => 'Object',
|
||||||
lazy => 1,
|
lazy => 1,
|
||||||
required => 1,
|
required => 1,
|
||||||
builder => '_build_ua',
|
builder => '_build_ua',
|
||||||
@@ -97,7 +101,7 @@ sub BUILD {
|
|||||||
}
|
}
|
||||||
|
|
||||||
my $entry_links = decode_json($self->response->content);
|
my $entry_links = decode_json($self->response->content);
|
||||||
PTDEBUG && _d('Entry links', $entry_links);
|
PTDEBUG && _d('Entry links', Dumper($entry_links));
|
||||||
|
|
||||||
$self->links($entry_links);
|
$self->links($entry_links);
|
||||||
|
|
||||||
@@ -107,21 +111,20 @@ sub BUILD {
|
|||||||
sub get {
|
sub get {
|
||||||
my ($self, %args) = @_;
|
my ($self, %args) = @_;
|
||||||
|
|
||||||
# Arguments:
|
have_required_args(\%args, qw(
|
||||||
my @required_args = (
|
url
|
||||||
'link', # A resource link (e.g. $run->links->{results})
|
)) or die;
|
||||||
);
|
my ($url) = $args{url};
|
||||||
my ($link) = @args{@required_args};
|
|
||||||
|
|
||||||
# Returns:
|
# Returns:
|
||||||
my @resources; # Resources from the requested link
|
my @resources;
|
||||||
|
|
||||||
# Get resource representations from the link. The server should always
|
# Get resource representations from the url. The server should always
|
||||||
# return a list of resource reps, even if there's only one resource.
|
# return a list of resource reps, even if there's only one resource.
|
||||||
eval {
|
eval {
|
||||||
$self->_request(
|
$self->_request(
|
||||||
method => 'GET',
|
method => 'GET',
|
||||||
url => $link,
|
url => $url,
|
||||||
);
|
);
|
||||||
};
|
};
|
||||||
if ( my $e = $EVAL_ERROR ) {
|
if ( my $e = $EVAL_ERROR ) {
|
||||||
@@ -185,19 +188,26 @@ sub post {
|
|||||||
);
|
);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
sub put {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->_set(
|
||||||
|
@_,
|
||||||
|
method => 'PUT',
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
sub delete {
|
sub delete {
|
||||||
my ($self, %args) = @_;
|
my ($self, %args) = @_;
|
||||||
|
|
||||||
# Arguments:
|
have_required_args(\%args, qw(
|
||||||
my @required_args = (
|
url
|
||||||
'link', # A resource link (e.g. $run->links->{results})
|
)) or die;
|
||||||
);
|
my ($url) = $args{url};
|
||||||
my ($link) = @args{@required_args};
|
|
||||||
|
|
||||||
eval {
|
eval {
|
||||||
$self->_request(
|
$self->_request(
|
||||||
method => 'DELETE',
|
method => 'DELETE',
|
||||||
url => $link,
|
url => $url,
|
||||||
headers => { 'Content-Length' => 0 },
|
headers => { 'Content-Length' => 0 },
|
||||||
);
|
);
|
||||||
};
|
};
|
||||||
@@ -215,12 +225,19 @@ sub delete {
|
|||||||
|
|
||||||
sub _set {
|
sub _set {
|
||||||
my ($self, %args) = @_;
|
my ($self, %args) = @_;
|
||||||
my @required_args = qw(method resources link);
|
|
||||||
my ($method, $res, $link) = @args{@required_args};
|
have_required_args(\%args, qw(
|
||||||
|
method
|
||||||
|
resources
|
||||||
|
url
|
||||||
|
)) or die;
|
||||||
|
my $method = $args{method};
|
||||||
|
my $res = $args{resources};
|
||||||
|
my $url = $args{url};
|
||||||
|
|
||||||
my $content;
|
my $content;
|
||||||
if ( ref($res) eq 'ARRAY' ) {
|
if ( ref($res) eq 'ARRAY' ) {
|
||||||
$content = '[' . join(",\n", map { $_->as_json } @$res) . ']';
|
$content = '[' . join(",\n", map { as_json($_) } @$res) . ']';
|
||||||
}
|
}
|
||||||
elsif ( -f $res ) {
|
elsif ( -f $res ) {
|
||||||
PTDEBUG && _d('Reading content from file', $res);
|
PTDEBUG && _d('Reading content from file', $res);
|
||||||
@@ -235,13 +252,13 @@ sub _set {
|
|||||||
$content .= $data;
|
$content .= $data;
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
$content = $res->as_json;
|
$content = as_json($res);
|
||||||
}
|
}
|
||||||
|
|
||||||
eval {
|
eval {
|
||||||
$self->_request(
|
$self->_request(
|
||||||
method => $method,
|
method => $method,
|
||||||
url => $link,
|
url => $url,
|
||||||
content => $content,
|
content => $content,
|
||||||
);
|
);
|
||||||
};
|
};
|
||||||
@@ -273,11 +290,12 @@ sub _set {
|
|||||||
sub _request {
|
sub _request {
|
||||||
my ($self, %args) = @_;
|
my ($self, %args) = @_;
|
||||||
|
|
||||||
my @required_args = (
|
have_required_args(\%args, qw(
|
||||||
'method',
|
method
|
||||||
'url',
|
url
|
||||||
);
|
)) or die;
|
||||||
my ($method, $url) = @args{@required_args};
|
my $method = $args{method};
|
||||||
|
my $url = $args{url};
|
||||||
|
|
||||||
my @optional_args = (
|
my @optional_args = (
|
||||||
'content',
|
'content',
|
||||||
@@ -290,10 +308,10 @@ sub _request {
|
|||||||
if ( uc($method) eq 'DELETE' ) {
|
if ( uc($method) eq 'DELETE' ) {
|
||||||
$self->ua->default_header('Content-Length' => 0);
|
$self->ua->default_header('Content-Length' => 0);
|
||||||
}
|
}
|
||||||
PTDEBUG && _d('Request', $method, $url, $req);
|
PTDEBUG && _d('Request', $method, $url, Dumper($req));
|
||||||
|
|
||||||
my $res = $self->ua->request($req);
|
my $res = $self->ua->request($req);
|
||||||
PTDEBUG && _d('Response', $res);
|
PTDEBUG && _d('Response', Dumper($res));
|
||||||
|
|
||||||
if ( uc($method) eq 'DELETE' ) {
|
if ( uc($method) eq 'DELETE' ) {
|
||||||
$self->ua->default_header('Content-Length' => undef);
|
$self->ua->default_header('Content-Length' => undef);
|
||||||
@@ -321,7 +339,7 @@ sub update_links {
|
|||||||
$self->links->{$svc}->{$rel} = $link;
|
$self->links->{$svc}->{$rel} = $link;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
PTDEBUG && _d('Updated links', $self->links);
|
PTDEBUG && _d('Updated links', Dumper($self->links));
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@@ -22,6 +22,14 @@ package Percona::WebAPI::Representation;
|
|||||||
|
|
||||||
use JSON;
|
use JSON;
|
||||||
|
|
||||||
|
require Exporter;
|
||||||
|
our @ISA = qw(Exporter);
|
||||||
|
our @EXPORT_OK = qw(
|
||||||
|
as_hashref
|
||||||
|
as_json
|
||||||
|
as_config
|
||||||
|
);
|
||||||
|
|
||||||
sub as_hashref {
|
sub as_hashref {
|
||||||
my $resource = shift;
|
my $resource = shift;
|
||||||
|
|
||||||
@@ -39,7 +47,6 @@ sub as_json {
|
|||||||
return encode_json(as_hashref(@_));
|
return encode_json(as_hashref(@_));
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
sub as_config {
|
sub as_config {
|
||||||
my $as_hashref = as_hashref(@_);
|
my $as_hashref = as_hashref(@_);
|
||||||
my $config = join("\n",
|
my $config = join("\n",
|
||||||
|
@@ -26,9 +26,7 @@ use Percona::WebAPI::Representation;
|
|||||||
|
|
||||||
require Exporter;
|
require Exporter;
|
||||||
our @ISA = qw(Exporter);
|
our @ISA = qw(Exporter);
|
||||||
our %EXPORT_TAGS = ();
|
|
||||||
our @EXPORT_OK = (qw(resource_diff));
|
our @EXPORT_OK = (qw(resource_diff));
|
||||||
our @EXPORT = ();
|
|
||||||
|
|
||||||
sub resource_diff {
|
sub resource_diff {
|
||||||
my ($x, $y) = @_;
|
my ($x, $y) = @_;
|
||||||
|
120
t/pt-agent/init_agent.t
Normal file
120
t/pt-agent/init_agent.t
Normal file
@@ -0,0 +1,120 @@
|
|||||||
|
#!/usr/bin/env perl
|
||||||
|
|
||||||
|
BEGIN {
|
||||||
|
die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n"
|
||||||
|
unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH};
|
||||||
|
unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib";
|
||||||
|
};
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings FATAL => 'all';
|
||||||
|
use English qw(-no_match_vars);
|
||||||
|
use Test::More;
|
||||||
|
use JSON;
|
||||||
|
|
||||||
|
use Percona::Test;
|
||||||
|
use Percona::Test::Mock::UserAgent;
|
||||||
|
require "$trunk/bin/pt-agent";
|
||||||
|
|
||||||
|
Percona::Toolkit->import(qw(Dumper));
|
||||||
|
Percona::WebAPI::Representation->import(qw(as_hashref));
|
||||||
|
|
||||||
|
my $ua = Percona::Test::Mock::UserAgent->new(
|
||||||
|
encode => sub { return encode_json(shift) },
|
||||||
|
);
|
||||||
|
|
||||||
|
# When Percona::WebAPI::Client is created, it gets its base_url,
|
||||||
|
# to get the API's entry links.
|
||||||
|
$ua->{responses}->{get} = [
|
||||||
|
{
|
||||||
|
content => {
|
||||||
|
agents => '/agents',
|
||||||
|
},
|
||||||
|
},
|
||||||
|
];
|
||||||
|
|
||||||
|
my $client = eval {
|
||||||
|
Percona::WebAPI::Client->new(
|
||||||
|
api_key => '123',
|
||||||
|
ua => $ua,
|
||||||
|
);
|
||||||
|
};
|
||||||
|
is(
|
||||||
|
$EVAL_ERROR,
|
||||||
|
'',
|
||||||
|
'Create Client with mock user agent'
|
||||||
|
) or die;
|
||||||
|
|
||||||
|
# #############################################################################
|
||||||
|
# Init a new agent, i.e. create it.
|
||||||
|
# #############################################################################
|
||||||
|
|
||||||
|
# Since we're passing agent_id, the tool will call its get_uuid()
|
||||||
|
# and POST an Agent resource to the fake ^ agents links. It then
|
||||||
|
# expects config and services links.
|
||||||
|
|
||||||
|
$ua->{responses}->{post} = [
|
||||||
|
{
|
||||||
|
content => {
|
||||||
|
links => {
|
||||||
|
agents => '/agents',
|
||||||
|
config => '/agents/123/config',
|
||||||
|
services => '/agents/123/services',
|
||||||
|
},
|
||||||
|
},
|
||||||
|
},
|
||||||
|
];
|
||||||
|
|
||||||
|
# interval is a callback that subs call to sleep between failed
|
||||||
|
# client requests. We're not faking a client request failure,
|
||||||
|
# so @wait should stay empty.
|
||||||
|
my @wait;
|
||||||
|
my $interval = sub {
|
||||||
|
my $t = shift;
|
||||||
|
push @wait, $t;
|
||||||
|
};
|
||||||
|
|
||||||
|
my $agent;
|
||||||
|
my $output = output(
|
||||||
|
sub {
|
||||||
|
$agent = pt_agent::init_agent(
|
||||||
|
client => $client,
|
||||||
|
interval => $interval,
|
||||||
|
);
|
||||||
|
},
|
||||||
|
stderr => 1,
|
||||||
|
);
|
||||||
|
|
||||||
|
is_deeply(
|
||||||
|
as_hashref($agent),
|
||||||
|
{
|
||||||
|
id => '123',
|
||||||
|
hostname => `hostname`,
|
||||||
|
versions => {
|
||||||
|
'Percona::WebAPI::Client' => "$Percona::WebAPI::Client::VERSION",
|
||||||
|
'Perl' => sprintf '%vd', $PERL_VERSION,
|
||||||
|
}
|
||||||
|
},
|
||||||
|
'Create new Agent'
|
||||||
|
) or diag(Dumper(as_hashref($agent)));
|
||||||
|
|
||||||
|
is(
|
||||||
|
scalar @wait,
|
||||||
|
0,
|
||||||
|
"Client did not wait"
|
||||||
|
);
|
||||||
|
|
||||||
|
is_deeply(
|
||||||
|
$client->links,
|
||||||
|
{
|
||||||
|
agents => '/agents',
|
||||||
|
config => '/agents/123/config',
|
||||||
|
services => '/agents/123/services',
|
||||||
|
},
|
||||||
|
"Client got new links"
|
||||||
|
) or diag(Dumper($client->links));
|
||||||
|
|
||||||
|
# #############################################################################
|
||||||
|
# Done.
|
||||||
|
# #############################################################################
|
||||||
|
done_testing;
|
Reference in New Issue
Block a user