diff --git a/bin/pt-agent b/bin/pt-agent index 1e0d349b..99b47b73 100755 --- a/bin/pt-agent +++ b/bin/pt-agent @@ -17,13 +17,13 @@ BEGIN { Lmo::Meta Lmo::Object Lmo + Percona::WebAPI::Representation Percona::WebAPI::Client Percona::WebAPI::Exception::Request Percona::WebAPI::Resource::Agent Percona::WebAPI::Resource::Config Percona::WebAPI::Resource::Service Percona::WebAPI::Resource::Run - Percona::WebAPI::Representation Percona::WebAPI::Util VersionCheck DSNParser @@ -56,12 +56,10 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0; use Carp qw(carp cluck); use Data::Dumper qw(); -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; -use Exporter 'import'; -our @EXPORT = qw( +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( have_required_args Dumper _d @@ -81,6 +79,9 @@ sub have_required_args { } sub Dumper { + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Quotekeys = 0; Data::Dumper::Dumper(@_); } @@ -671,6 +672,56 @@ BEGIN { # 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 # 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 Percona::Toolkit; +use Percona::WebAPI::Representation; use Percona::WebAPI::Exception::Request; +Percona::WebAPI::Representation->import(qw(as_json)); +Percona::Toolkit->import(qw(_d Dumper have_required_args)); + has 'api_key' => ( is => 'ro', isa => 'Str', @@ -707,8 +762,8 @@ has 'api_key' => ( has 'base_url' => ( is => 'rw', isa => 'Str', - default => 'https://api.tools.percona.com', - required => 1, + default => sub { return 'https://api.tools.percona.com' }, + required => 0, ); has 'links' => ( @@ -720,7 +775,7 @@ has 'links' => ( has 'ua' => ( is => 'rw', - isa => 'LWP::UserAgent', + isa => 'Object', lazy => 1, required => 1, builder => '_build_ua', @@ -759,7 +814,7 @@ sub BUILD { } 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); @@ -768,18 +823,18 @@ sub BUILD { sub get { my ($self, %args) = @_; + + have_required_args(\%args, qw( + url + )) or die; + my ($url) = $args{url}; - my @required_args = ( - 'link', # A resource link (e.g. $run->links->{results}) - ); - my ($link) = @args{@required_args}; - - my @resources; # Resources from the requested link + my @resources; eval { $self->_request( method => 'GET', - url => $link, + url => $url, ); }; if ( my $e = $EVAL_ERROR ) { @@ -839,18 +894,26 @@ sub post { ); } +sub put { + my $self = shift; + return $self->_set( + @_, + method => 'PUT', + ); +} + sub delete { my ($self, %args) = @_; - my @required_args = ( - 'link', # A resource link (e.g. $run->links->{results}) - ); - my ($link) = @args{@required_args}; + have_required_args(\%args, qw( + url + )) or die; + my ($url) = $args{url}; eval { $self->_request( method => 'DELETE', - url => $link, + url => $url, headers => { 'Content-Length' => 0 }, ); }; @@ -868,12 +931,19 @@ sub delete { sub _set { 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; if ( ref($res) eq 'ARRAY' ) { - $content = '[' . join(",\n", map { $_->as_json } @$res) . ']'; + $content = '[' . join(",\n", map { as_json($_) } @$res) . ']'; } elsif ( -f $res ) { PTDEBUG && _d('Reading content from file', $res); @@ -888,13 +958,13 @@ sub _set { $content .= $data; } else { - $content = $res->as_json; + $content = as_json($res); } eval { $self->_request( method => $method, - url => $link, + url => $url, content => $content, ); }; @@ -926,11 +996,12 @@ sub _set { sub _request { my ($self, %args) = @_; - my @required_args = ( - 'method', - 'url', - ); - my ($method, $url) = @args{@required_args}; + have_required_args(\%args, qw( + method + url + )) or die; + my $method = $args{method}; + my $url = $args{url}; my @optional_args = ( 'content', @@ -943,10 +1014,10 @@ sub _request { if ( uc($method) eq 'DELETE' ) { $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); - PTDEBUG && _d('Response', $res); + PTDEBUG && _d('Response', Dumper($res)); if ( uc($method) eq 'DELETE' ) { $self->ua->default_header('Content-Length' => undef); @@ -974,7 +1045,7 @@ sub update_links { $self->links->{$svc}->{$rel} = $link; } } - PTDEBUG && _d('Updated links', $self->links); + PTDEBUG && _d('Updated links', Dumper($self->links)); return; } @@ -1191,49 +1262,6 @@ no Lmo; # 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 # This package is a copy without comments from the original. The original @@ -1250,10 +1278,8 @@ use Digest::MD5 qw(md5_hex); use Percona::WebAPI::Representation; require Exporter; -our @ISA = qw(Exporter); -our %EXPORT_TAGS = (); -our @EXPORT_OK = (qw(resource_diff)); -our @EXPORT = (); +our @ISA = qw(Exporter); +our @EXPORT_OK = (qw(resource_diff)); sub resource_diff { my ($x, $y) = @_; @@ -4304,7 +4330,7 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0; use POSIX qw(signal_h); use Time::HiRes qw(sleep time); -use Percona::Toolkit; +use Percona::Toolkit; use Percona::WebAPI::Client; use Percona::WebAPI::Exception::Request; use Percona::WebAPI::Resource::Agent; @@ -4314,6 +4340,8 @@ use Percona::WebAPI::Resource::Run; use Percona::WebAPI::Representation; use Percona::WebAPI::Util qw(resource_diff); +Percona::Toolkit->import(qw(_d Dumper have_required_args)); + use sigtrap 'handler', \&sig_int, 'normal-signals'; my $oktorun = 1; @@ -4474,7 +4502,7 @@ sub main { sub get_api_client { my (%args) = @_; - have_required_args(\%args,qw( + have_required_args(\%args, qw( api_key interval )) or die; @@ -4553,8 +4581,8 @@ sub init_agent { : "Creating new agent $agent_id"); eval { $client->$action( - url => $client->links->{agent}, - content => $agent, + url => $client->links->{agents}, + resources => $agent, ); }; if ( $EVAL_ERROR ) { @@ -4562,7 +4590,8 @@ sub init_agent { $interval->(); } else { - _info("Initialized") + _info("Initialized"); + last; } } @@ -4685,7 +4714,8 @@ sub _log { my ($level, $msg) = @_; my ($s, $m, $h, $d, $M) = localtime; 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; } @@ -4711,7 +4741,7 @@ sub get_uuid { sub get_versions { return { - 'Perl' => "5.10.1", + 'Perl' => "5.10.0", 'Percona::WebAPI::Client' => "$Percona::WebAPI::Client::VERSION", }; } diff --git a/lib/Percona/Test.pm b/lib/Percona/Test.pm new file mode 100644 index 00000000..4c87d544 --- /dev/null +++ b/lib/Percona/Test.pm @@ -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 +# ########################################################################### diff --git a/lib/Percona/Test/Mock/UserAgent.pm b/lib/Percona/Test/Mock/UserAgent.pm new file mode 100644 index 00000000..877344d6 --- /dev/null +++ b/lib/Percona/Test/Mock/UserAgent.pm @@ -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 +# ########################################################################### diff --git a/lib/Percona/Toolkit.pm b/lib/Percona/Toolkit.pm index af3dd5e1..7b00acc0 100644 --- a/lib/Percona/Toolkit.pm +++ b/lib/Percona/Toolkit.pm @@ -17,7 +17,6 @@ # ########################################################################### # Percona::Toolkit package # ########################################################################### -{ package Percona::Toolkit; our $VERSION = '3.0.0'; @@ -29,12 +28,10 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0; use Carp qw(carp cluck); use Data::Dumper qw(); -$Data::Dumper::Indent = 1; -$Data::Dumper::Sortkeys = 1; -$Data::Dumper::Quotekeys = 0; -use Exporter 'import'; -our @EXPORT = qw( +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( have_required_args Dumper _d @@ -54,6 +51,9 @@ sub have_required_args { } sub Dumper { + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Quotekeys = 0; Data::Dumper::Dumper(@_); } @@ -66,7 +66,6 @@ sub _d { } 1; -} # ########################################################################### # End Percona::Toolkit package # ########################################################################### diff --git a/lib/Percona/WebAPI/Client.pm b/lib/Percona/WebAPI/Client.pm index ddf76804..7df8b927 100644 --- a/lib/Percona/WebAPI/Client.pm +++ b/lib/Percona/WebAPI/Client.pm @@ -34,8 +34,12 @@ use English qw(-no_match_vars); use Lmo; use Percona::Toolkit; +use Percona::WebAPI::Representation; use Percona::WebAPI::Exception::Request; +Percona::WebAPI::Representation->import(qw(as_json)); +Percona::Toolkit->import(qw(_d Dumper have_required_args)); + has 'api_key' => ( is => 'ro', isa => 'Str', @@ -45,8 +49,8 @@ has 'api_key' => ( has 'base_url' => ( is => 'rw', isa => 'Str', - default => 'https://api.tools.percona.com', - required => 1, + default => sub { return 'https://api.tools.percona.com' }, + required => 0, ); has 'links' => ( @@ -58,7 +62,7 @@ has 'links' => ( has 'ua' => ( is => 'rw', - isa => 'LWP::UserAgent', + isa => 'Object', lazy => 1, required => 1, builder => '_build_ua', @@ -97,7 +101,7 @@ sub BUILD { } 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); @@ -106,22 +110,21 @@ sub BUILD { sub get { my ($self, %args) = @_; - - # Arguments: - my @required_args = ( - 'link', # A resource link (e.g. $run->links->{results}) - ); - my ($link) = @args{@required_args}; + + have_required_args(\%args, qw( + url + )) or die; + my ($url) = $args{url}; # 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. eval { $self->_request( method => 'GET', - url => $link, + url => $url, ); }; if ( my $e = $EVAL_ERROR ) { @@ -185,19 +188,26 @@ sub post { ); } +sub put { + my $self = shift; + return $self->_set( + @_, + method => 'PUT', + ); +} + sub delete { my ($self, %args) = @_; - # Arguments: - my @required_args = ( - 'link', # A resource link (e.g. $run->links->{results}) - ); - my ($link) = @args{@required_args}; + have_required_args(\%args, qw( + url + )) or die; + my ($url) = $args{url}; eval { $self->_request( method => 'DELETE', - url => $link, + url => $url, headers => { 'Content-Length' => 0 }, ); }; @@ -215,12 +225,19 @@ sub delete { sub _set { 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; if ( ref($res) eq 'ARRAY' ) { - $content = '[' . join(",\n", map { $_->as_json } @$res) . ']'; + $content = '[' . join(",\n", map { as_json($_) } @$res) . ']'; } elsif ( -f $res ) { PTDEBUG && _d('Reading content from file', $res); @@ -235,13 +252,13 @@ sub _set { $content .= $data; } else { - $content = $res->as_json; + $content = as_json($res); } eval { $self->_request( method => $method, - url => $link, + url => $url, content => $content, ); }; @@ -273,11 +290,12 @@ sub _set { sub _request { my ($self, %args) = @_; - my @required_args = ( - 'method', - 'url', - ); - my ($method, $url) = @args{@required_args}; + have_required_args(\%args, qw( + method + url + )) or die; + my $method = $args{method}; + my $url = $args{url}; my @optional_args = ( 'content', @@ -290,10 +308,10 @@ sub _request { if ( uc($method) eq 'DELETE' ) { $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); - PTDEBUG && _d('Response', $res); + PTDEBUG && _d('Response', Dumper($res)); if ( uc($method) eq 'DELETE' ) { $self->ua->default_header('Content-Length' => undef); @@ -321,7 +339,7 @@ sub update_links { $self->links->{$svc}->{$rel} = $link; } } - PTDEBUG && _d('Updated links', $self->links); + PTDEBUG && _d('Updated links', Dumper($self->links)); return; } diff --git a/lib/Percona/WebAPI/Representation.pm b/lib/Percona/WebAPI/Representation.pm index f1632d85..9bd3ff9c 100644 --- a/lib/Percona/WebAPI/Representation.pm +++ b/lib/Percona/WebAPI/Representation.pm @@ -22,6 +22,14 @@ 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; @@ -39,7 +47,6 @@ sub as_json { return encode_json(as_hashref(@_)); } - sub as_config { my $as_hashref = as_hashref(@_); my $config = join("\n", diff --git a/lib/Percona/WebAPI/Util.pm b/lib/Percona/WebAPI/Util.pm index 0c3a5dea..e972b969 100644 --- a/lib/Percona/WebAPI/Util.pm +++ b/lib/Percona/WebAPI/Util.pm @@ -25,10 +25,8 @@ use Digest::MD5 qw(md5_hex); use Percona::WebAPI::Representation; require Exporter; -our @ISA = qw(Exporter); -our %EXPORT_TAGS = (); -our @EXPORT_OK = (qw(resource_diff)); -our @EXPORT = (); +our @ISA = qw(Exporter); +our @EXPORT_OK = (qw(resource_diff)); sub resource_diff { my ($x, $y) = @_; diff --git a/t/pt-agent/init_agent.t b/t/pt-agent/init_agent.t new file mode 100644 index 00000000..4eed0c63 --- /dev/null +++ b/t/pt-agent/init_agent.t @@ -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;