3
# This program is part of Percona Toolkit: http://www.percona.com/software/
4
# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
5
# notices and disclaimers.
8
use warnings FATAL => 'all';
10
# This tool is "fat-packed": most of its dependent modules are embedded
11
# in this file. Setting %INC to this file for each module makes Perl aware
12
# of this so it will not try to load the module from @INC. See the tool's
13
# documentation for a full list of dependencies.
15
$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
22
Percona::WebAPI::Representation
23
Percona::WebAPI::Client
24
Percona::WebAPI::Exception::Request
25
Percona::WebAPI::Exception::Resource
26
Percona::WebAPI::Resource::Agent
27
Percona::WebAPI::Resource::Config
28
Percona::WebAPI::Resource::Service
29
Percona::WebAPI::Resource::Task
30
Percona::WebAPI::Resource::LogEntry
40
Percona::Agent::Logger
44
# ###########################################################################
45
# Percona::Toolkit package
46
# This package is a copy without comments from the original. The original
47
# with comments and its test file can be found in the Bazaar repository at,
48
# lib/Percona/Toolkit.pm
49
# t/lib/Percona/Toolkit.t
50
# See https://launchpad.net/percona-toolkit for more information.
51
# ###########################################################################
53
package Percona::Toolkit;
55
our $VERSION = '2.2.7';
58
use warnings FATAL => 'all';
59
use English qw(-no_match_vars);
60
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
62
use Carp qw(carp cluck);
63
use Data::Dumper qw();
66
our @ISA = qw(Exporter);
73
sub have_required_args {
74
my ($args, @required_args) = @_;
75
my $have_required_args = 1;
76
foreach my $arg ( @required_args ) {
77
if ( !defined $args->{$arg} ) {
78
$have_required_args = 0;
79
carp "Argument $arg is not defined";
82
cluck unless $have_required_args; # print backtrace
83
return $have_required_args;
87
local $Data::Dumper::Indent = 1;
88
local $Data::Dumper::Sortkeys = 1;
89
local $Data::Dumper::Quotekeys = 0;
90
Data::Dumper::Dumper(@_);
94
my ($package, undef, $line) = caller 0;
95
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
96
map { defined $_ ? $_ : 'undef' }
98
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
103
# ###########################################################################
104
# End Percona::Toolkit package
105
# ###########################################################################
107
# ###########################################################################
109
# This package is a copy without comments from the original. The original
110
# with comments and its test file can be found in the Bazaar repository at,
113
# See https://launchpad.net/percona-toolkit for more information.
114
# ###########################################################################
119
use warnings qw( FATAL all );
121
our (@ISA, @EXPORT, @EXPORT_OK);
125
@EXPORT = @EXPORT_OK = qw(
140
return \%{ shift() . "::" };
144
sub _install_coderef {
145
my ($to, $code) = @_;
147
return *{ _glob_for $to } = $code;
150
sub _unimport_coderefs {
151
my ($target, @names) = @_;
152
return unless @names;
153
my $stash = _stash_for($target);
154
foreach my $name (@names) {
155
if ($stash->{$name} and defined(&{$stash->{$name}})) {
156
delete $stash->{$name};
163
# ###########################################################################
164
# End Lmo::Utils package
165
# ###########################################################################
167
# ###########################################################################
169
# This package is a copy without comments from the original. The original
170
# with comments and its test file can be found in the Bazaar repository at,
173
# See https://launchpad.net/percona-toolkit for more information.
174
# ###########################################################################
178
use warnings qw( FATAL all );
184
return bless { @_ }, $class
191
return $metadata_for{$class} ||= {};
194
sub class { shift->{class} }
198
return keys %{$self->metadata_for($self->class)}
201
sub attributes_for_new {
205
my $class_metadata = $self->metadata_for($self->class);
206
while ( my ($attr, $meta) = each %$class_metadata ) {
207
if ( exists $meta->{init_arg} ) {
208
push @attributes, $meta->{init_arg}
209
if defined $meta->{init_arg};
212
push @attributes, $attr;
220
# ###########################################################################
221
# End Lmo::Meta package
222
# ###########################################################################
224
# ###########################################################################
225
# Lmo::Object package
226
# This package is a copy without comments from the original. The original
227
# with comments and its test file can be found in the Bazaar repository at,
230
# See https://launchpad.net/percona-toolkit for more information.
231
# ###########################################################################
236
use warnings qw( FATAL all );
239
use Scalar::Util qw(blessed);
242
use Lmo::Utils qw(_glob_for);
246
my $args = $class->BUILDARGS(@_);
248
my $class_metadata = Lmo::Meta->metadata_for($class);
251
while ( my ($attr, $meta) = each %$class_metadata ) {
252
next unless exists $meta->{init_arg};
253
my $init_arg = $meta->{init_arg};
255
if ( defined $init_arg ) {
256
$args->{$attr} = delete $args->{$init_arg};
259
push @args_to_delete, $attr;
263
delete $args->{$_} for @args_to_delete;
265
for my $attribute ( keys %$args ) {
266
if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
267
$args->{$attribute} = $coerce->($args->{$attribute});
269
if ( my $isa_check = $class_metadata->{$attribute}{isa} ) {
270
my ($check_name, $check_sub) = @$isa_check;
271
$check_sub->($args->{$attribute});
275
while ( my ($attribute, $meta) = each %$class_metadata ) {
276
next unless $meta->{required};
277
Carp::confess("Attribute ($attribute) is required for $class")
278
if ! exists $args->{$attribute}
281
my $self = bless $args, $class;
284
my $linearized_isa = mro::get_linear_isa($class);
286
for my $isa_class ( @$linearized_isa ) {
287
unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE};
290
for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
291
$sub->( $self, @args);
297
shift; # No need for the classname
298
if ( @_ == 1 && ref($_[0]) ) {
299
Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]")
300
unless ref($_[0]) eq ref({});
301
return {%{$_[0]}} # We want a new reference, always
310
$class = Scalar::Util::blessed($class) || $class;
311
return Lmo::Meta->new(class => $class);
316
# ###########################################################################
317
# End Lmo::Object package
318
# ###########################################################################
320
# ###########################################################################
322
# This package is a copy without comments from the original. The original
323
# with comments and its test file can be found in the Bazaar repository at,
326
# See https://launchpad.net/percona-toolkit for more information.
327
# ###########################################################################
332
use warnings qw( FATAL all );
335
use Scalar::Util qw(looks_like_number blessed);
339
Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) },
340
Num => sub { defined $_[0] && looks_like_number($_[0]) },
341
Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) },
342
Str => sub { defined $_[0] },
343
Object => sub { defined $_[0] && blessed($_[0]) },
344
FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened },
347
my $type = /R/ ? $_ : uc $_;
348
$_ . "Ref" => sub { ref $_[0] eq $type }
349
} qw(Array Code Hash Regexp Glob Scalar)
352
sub check_type_constaints {
353
my ($attribute, $type_check, $check_name, $val) = @_;
354
( ref($type_check) eq 'CODE'
355
? $type_check->($val)
356
: (ref $val eq $type_check
357
|| ($val && $val eq $type_check)
358
|| (exists $TYPES{$type_check} && $TYPES{$type_check}->($val)))
361
qq<Attribute ($attribute) does not pass the type constraint because: >
362
. qq<Validation failed for '$check_name' with value >
363
. (defined $val ? Lmo::Dumper($val) : 'undef') )
366
sub _nested_constraints {
367
my ($attribute, $aggregate_type, $type) = @_;
370
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
371
$inner_types = _nested_constraints($1, $2);
374
$inner_types = $TYPES{$type};
377
if ( $aggregate_type eq 'ArrayRef' ) {
380
return unless ref($val) eq ref([]);
383
for my $value ( @{$val} ) {
384
return unless $inner_types->($value)
388
for my $value ( @{$val} ) {
389
return unless $value && ($value eq $type
390
|| (Scalar::Util::blessed($value) && $value->isa($type)));
396
elsif ( $aggregate_type eq 'Maybe' ) {
399
return 1 if ! defined($value);
401
return unless $inner_types->($value)
404
return unless $value eq $type
405
|| (Scalar::Util::blessed($value) && $value->isa($type));
411
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
417
# ###########################################################################
418
# End Lmo::Types package
419
# ###########################################################################
421
# ###########################################################################
423
# This package is a copy without comments from the original. The original
424
# with comments and its test file can be found in the Bazaar repository at,
427
# See https://launchpad.net/percona-toolkit for more information.
428
# ###########################################################################
431
$INC{"Lmo.pm"} = __FILE__;
433
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
437
use warnings qw( FATAL all );
440
use Scalar::Util qw(looks_like_number blessed);
450
warnings->import(qw(FATAL all));
453
my $caller = scalar caller(); # Caller's package
455
extends => \&extends,
458
override => \&override,
459
confess => \&Carp::confess,
462
$export_for{$caller} = \%exports;
464
for my $keyword ( keys %exports ) {
465
_install_coderef "${caller}::$keyword" => $exports{$keyword};
468
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
470
goto *{ _glob_for "${caller}::extends" }{CODE};
475
my $caller = scalar caller();
476
for my $class ( @_ ) {
477
_load_module($class);
479
_set_package_isa($caller, @_);
480
_set_inherited_metadata($caller);
486
(my $file = $class) =~ s{::|'}{/}g;
488
{ local $@; eval { require "$file" } } # or warn $@;
493
my $package = scalar caller();
495
for my $role ( @_ ) {
497
_role_attribute_metadata($package, $role);
499
Role::Tiny->apply_roles_to_package($package, @_);
502
sub _role_attribute_metadata {
503
my ($package, $role) = @_;
505
my $package_meta = Lmo::Meta->metadata_for($package);
506
my $role_meta = Lmo::Meta->metadata_for($role);
508
%$package_meta = (%$role_meta, %$package_meta);
513
my $caller = scalar caller();
515
my $class_metadata = Lmo::Meta->metadata_for($caller);
517
for my $attribute ( ref $names ? @$names : $names ) {
519
my $method = ($args{is} || '') eq 'ro'
521
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
523
return $_[0]{$attribute};
527
? $_[0]{$attribute} = $_[1]
531
$class_metadata->{$attribute} = ();
533
if ( my $type_check = $args{isa} ) {
534
my $check_name = $type_check;
536
if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
537
$type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
540
my $check_sub = sub {
542
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
545
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
546
my $orig_method = $method;
548
$check_sub->($_[1]) if $#_;
553
if ( my $builder = $args{builder} ) {
554
my $original_method = $method;
557
? goto &$original_method
558
: ! exists $_[0]{$attribute}
559
? $_[0]{$attribute} = $_[0]->$builder
560
: goto &$original_method
564
if ( my $code = $args{default} ) {
565
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
566
unless ref($code) eq 'CODE';
567
my $original_method = $method;
570
? goto &$original_method
571
: ! exists $_[0]{$attribute}
572
? $_[0]{$attribute} = $_[0]->$code
573
: goto &$original_method
577
if ( my $role = $args{does} ) {
578
my $original_method = $method;
581
Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
582
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
584
goto &$original_method
588
if ( my $coercion = $args{coerce} ) {
589
$class_metadata->{$attribute}{coerce} = $coercion;
590
my $original_method = $method;
593
return $original_method->($_[0], $coercion->($_[1]))
595
goto &$original_method;
599
_install_coderef "${caller}::$attribute" => $method;
601
if ( $args{required} ) {
602
$class_metadata->{$attribute}{required} = 1;
605
if ($args{clearer}) {
606
_install_coderef "${caller}::$args{clearer}"
607
=> sub { delete shift->{$attribute} }
610
if ($args{predicate}) {
611
_install_coderef "${caller}::$args{predicate}"
612
=> sub { exists shift->{$attribute} }
615
if ($args{handles}) {
616
_has_handles($caller, $attribute, \%args);
619
if (exists $args{init_arg}) {
620
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
626
my ($caller, $attribute, $args) = @_;
627
my $handles = $args->{handles};
629
my $ref = ref $handles;
631
if ( $ref eq ref [] ) {
632
$kv = { map { $_,$_ } @{$handles} };
634
elsif ( $ref eq ref {} ) {
637
elsif ( $ref eq ref qr// ) {
638
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
640
my $target_class = $args->{isa};
643
grep { $_ =~ $handles }
644
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
645
grep { !$export_for{$target_class}->{$_} }
646
keys %{ _stash_for $target_class }
650
Carp::confess("handles for $ref not yet implemented");
653
while ( my ($method, $target) = each %{$kv} ) {
654
my $name = _glob_for "${caller}::$method";
655
Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
658
my ($target, @curried_args) = ref($target) ? @$target : $target;
661
my $delegate_to = $self->$attribute();
662
my $error = "Cannot delegate $method to $target because the value of $attribute";
663
Carp::confess("$error is not defined") unless $delegate_to;
664
Carp::confess("$error is not an object (got '$delegate_to')")
665
unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
666
return $delegate_to->$target(@curried_args, @_);
671
sub _set_package_isa {
672
my ($package, @new_isa) = @_;
673
my $package_isa = \*{ _glob_for "${package}::ISA" };
674
@{*$package_isa} = @new_isa;
677
sub _set_inherited_metadata {
679
my $class_metadata = Lmo::Meta->metadata_for($class);
680
my $linearized_isa = mro::get_linear_isa($class);
683
for my $isa_class (reverse @$linearized_isa) {
684
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
690
%$class_metadata = %new_metadata;
694
my $caller = scalar caller();
696
_unimport_coderefs($target, keys %{$export_for{$caller}});
700
require Data::Dumper;
701
local $Data::Dumper::Indent = 0;
702
local $Data::Dumper::Sortkeys = 0;
703
local $Data::Dumper::Quotekeys = 0;
704
local $Data::Dumper::Terse = 1;
706
Data::Dumper::Dumper(@_)
711
{ local $@; require mro; }
718
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
721
my $classname = shift;
723
my @lin = ($classname);
725
foreach my $parent (@{"$classname\::ISA"}) {
726
my $plin = mro::get_linear_isa_dfs($parent);
728
next if exists $stored{$_};
740
my ($methods, $code) = @_;
741
my $caller = scalar caller;
743
for my $method ( ref($methods) ? @$methods : $methods ) {
744
my $full_method = "${caller}::${method}";
745
*{_glob_for $full_method} = $code;
752
# ###########################################################################
754
# ###########################################################################
756
# ###########################################################################
757
# Percona::WebAPI::Representation package
758
# This package is a copy without comments from the original. The original
759
# with comments and its test file can be found in the Bazaar repository at,
760
# lib/Percona/WebAPI/Representation.pm
761
# t/lib/Percona/WebAPI/Representation.t
762
# See https://launchpad.net/percona-toolkit for more information.
763
# ###########################################################################
765
package Percona::WebAPI::Representation;
772
our @ISA = qw(Exporter);
780
my ($resource, %args) = @_;
782
my $as_hashref = { %$resource };
784
if ( !defined $args{with_links} || !$args{with_links} ) {
785
delete $as_hashref->{links};
792
my ($resource, %args) = @_;
794
my $json = $args{json} || JSON->new;
795
$json->allow_blessed([]);
796
$json->convert_blessed([]);
798
my $text = $json->encode(
799
ref $resource eq 'ARRAY' ? $resource : as_hashref($resource, %args)
801
if ( $args{json} && $text ) { # for testing
809
my $resource = shift;
810
if ( !$resource->isa('Percona::WebAPI::Resource::Config') ) {
811
die "Only Config resources can be represented as config.\n";
813
my $as_hashref = as_hashref($resource);
814
my $options = $as_hashref->{options};
815
my $config = join("\n",
816
map { defined $options->{$_} ? "$_=$options->{$_}" : "$_" }
824
# ###########################################################################
825
# End Percona::WebAPI::Representation package
826
# ###########################################################################
828
# ###########################################################################
829
# Percona::WebAPI::Client package
830
# This package is a copy without comments from the original. The original
831
# with comments and its test file can be found in the Bazaar repository at,
832
# lib/Percona/WebAPI/Client.pm
833
# t/lib/Percona/WebAPI/Client.t
834
# See https://launchpad.net/percona-toolkit for more information.
835
# ###########################################################################
837
package Percona::WebAPI::Client;
839
our $VERSION = '0.01';
842
use warnings FATAL => 'all';
843
use English qw(-no_match_vars);
844
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
851
use Scalar::Util qw(blessed);
854
use Percona::Toolkit;
855
use Percona::WebAPI::Representation;
856
use Percona::WebAPI::Exception::Request;
857
use Percona::WebAPI::Exception::Resource;
859
Percona::WebAPI::Representation->import(qw(as_json));
860
Percona::Toolkit->import(qw(_d Dumper have_required_args));
868
has 'entry_link' => (
872
default => sub { return 'https://cloud-api.percona.com' },
880
builder => '_build_ua',
892
my $ua = LWP::UserAgent->new;
893
$ua->agent("Percona::WebAPI::Client/$Percona::WebAPI::Client::VERSION");
894
$ua->default_header('Content-Type', 'application/json');
895
$ua->default_header('X-Percona-API-Key', $self->api_key);
900
my ($self, %args) = @_;
902
have_required_args(\%args, qw(
905
my ($link) = $args{link};
913
if ( my $e = $EVAL_ERROR ) {
914
if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
918
die "Unknown error: $e";
922
my $resource = eval {
923
JSON::decode_json($self->response->content);
926
warn sprintf "Error decoding resource: %s: %s",
927
$self->response->content,
932
my $resource_objects;
933
if ( my $type = $self->response->headers->{'x-percona-resource-type'} ) {
935
$type = "Percona::WebAPI::Resource::$type";
936
if ( ref $resource eq 'ARRAY' ) {
937
PTDEBUG && _d('Got a list of', $type, 'resources');
938
$resource_objects = [];
939
foreach my $attribs ( @$resource ) {
940
my $obj = $type->new(%$attribs);
941
push @$resource_objects, $obj;
945
PTDEBUG && _d('Got a', $type, 'resource', Dumper($resource));
946
$resource_objects = $type->new(%$resource);
949
if ( my $e = $EVAL_ERROR ) {
950
die Percona::WebAPI::Exception::Resource->new(
953
data => (ref $resource eq 'ARRAY' ? $resource : [ $resource ]),
958
elsif ( exists $resource->{links} ) {
959
$resource_objects = $resource->{links};
961
elsif ( exists $resource->{pong} ) {
962
PTDEBUG && _d("Ping pong!");
965
warn "Did not get X-Percona-Resource-Type or links from $link\n";
968
return $resource_objects;
977
return $self->response->header('Location');
986
return $self->response->header('Location');
990
my ($self, %args) = @_;
991
have_required_args(\%args, qw(
994
my ($link) = $args{link};
1000
headers => { 'Content-Length' => 0 },
1003
if ( my $e = $EVAL_ERROR ) {
1004
if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
1008
die "Unknown error: $e";
1016
my ($self, %args) = @_;
1017
have_required_args(\%args, qw(
1022
my $method = $args{method};
1023
my $res = $args{resources};
1024
my $link = $args{link};
1026
my $headers = $args{headers};
1029
if ( ref($res) eq 'ARRAY' ) {
1030
PTDEBUG && _d('List of resources');
1031
$content = '[' . join(",\n", map { as_json($_) } @$res) . ']';
1033
elsif ( ref($res) ) {
1034
PTDEBUG && _d('Resource object');
1035
$content = as_json($res);
1037
elsif ( $res !~ m/\n/ && -f $res ) {
1038
PTDEBUG && _d('List of resources in file', $res);
1041
local $INPUT_RECORD_SEPARATOR = undef;
1042
open my $fh, '<', $res
1043
or die "Error opening $res: $OS_ERROR";
1046
$data =~ s/,?\s*$/]/;
1050
PTDEBUG && _d('Resource text');
1058
content => $content,
1059
headers => $headers,
1062
if ( my $e = $EVAL_ERROR ) {
1063
if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
1067
die "Unknown error: $e";
1075
my ($self, %args) = @_;
1077
have_required_args(\%args, qw(
1081
my $method = $args{method};
1082
my $link = $args{link};
1084
my $content = $args{content};
1085
my $headers = $args{headers};
1087
my $req = HTTP::Request->new($method => $link);
1089
$req->content($content);
1092
map { $req->header($_ => $headers->{$_}) } keys %$headers;
1094
PTDEBUG && _d('Request', $method, $link, Dumper($req));
1096
my $response = $self->ua->request($req);
1097
PTDEBUG && _d('Response', Dumper($response));
1099
$self->response($response);
1101
if ( !($response->code >= 200 && $response->code < 400) ) {
1102
die Percona::WebAPI::Exception::Request->new(
1105
content => $content,
1106
status => $response->code,
1107
error => "Failed to $method $link",
1117
# ###########################################################################
1118
# End Percona::WebAPI::Client package
1119
# ###########################################################################
1121
# ###########################################################################
1122
# Percona::WebAPI::Exception::Request package
1123
# This package is a copy without comments from the original. The original
1124
# with comments and its test file can be found in the Bazaar repository at,
1125
# lib/Percona/WebAPI/Exception/Request.pm
1126
# t/lib/Percona/WebAPI/Exception/Request.t
1127
# See https://launchpad.net/percona-toolkit for more information.
1128
# ###########################################################################
1130
package Percona::WebAPI::Exception::Request;
1133
use overload '""' => \&as_string;
1149
isa => 'Maybe[Str]',
1167
chomp(my $error = $self->error);
1169
return sprintf "%s\nRequest: %s %s %s\nStatus: %d\n",
1170
$error, $self->method, $self->url, $self->content || '', $self->status;
1176
# ###########################################################################
1177
# End Percona::WebAPI::Exception::Request package
1178
# ###########################################################################
1180
# ###########################################################################
1181
# Percona::WebAPI::Exception::Resource package
1182
# This package is a copy without comments from the original. The original
1183
# with comments and its test file can be found in the Bazaar repository at,
1184
# lib/Percona/WebAPI/Exception/Resource.pm
1185
# t/lib/Percona/WebAPI/Exception/Resource.t
1186
# See https://launchpad.net/percona-toolkit for more information.
1187
# ###########################################################################
1189
package Percona::WebAPI::Exception::Resource;
1192
use overload '""' => \&as_string;
1221
chomp(my $error = $self->error);
1222
local $Data::Dumper::Indent = 1;
1223
local $Data::Dumper::Sortkeys = 1;
1224
local $Data::Dumper::Quotekeys = 0;
1225
return sprintf "Invalid %s resource from %s:\n\n%s\nError: %s\n\n",
1226
$self->type, $self->link, Dumper($self->data), $error;
1232
# ###########################################################################
1233
# End Percona::WebAPI::Exception::Resource package
1234
# ###########################################################################
1236
# ###########################################################################
1237
# Percona::WebAPI::Resource::Agent package
1238
# This package is a copy without comments from the original. The original
1239
# with comments and its test file can be found in the Bazaar repository at,
1240
# lib/Percona/WebAPI/Resource/Agent.pm
1241
# t/lib/Percona/WebAPI/Resource/Agent.t
1242
# See https://launchpad.net/percona-toolkit for more information.
1243
# ###########################################################################
1245
package Percona::WebAPI::Resource::Agent;
1259
default => sub { return $ENV{USER} || $ENV{LOGNAME} },
1267
chomp(my $hostname = `hostname`);
1280
isa => 'Maybe[HashRef]',
1286
isa => 'Maybe[HashRef]',
1288
default => sub { return {} },
1293
return $self->alias || $self->hostname || $self->uuid || 'Unknown';
1299
# ###########################################################################
1300
# End Percona::WebAPI::Resource::Agent package
1301
# ###########################################################################
1303
# ###########################################################################
1304
# Percona::WebAPI::Resource::Config package
1305
# This package is a copy without comments from the original. The original
1306
# with comments and its test file can be found in the Bazaar repository at,
1307
# lib/Percona/WebAPI/Resource/Config.pm
1308
# t/lib/Percona/WebAPI/Resource/Config.t
1309
# See https://launchpad.net/percona-toolkit for more information.
1310
# ###########################################################################
1312
package Percona::WebAPI::Resource::Config;
1336
isa => 'Maybe[HashRef]',
1338
default => sub { return {} },
1344
# ###########################################################################
1345
# End Percona::WebAPI::Resource::Config package
1346
# ###########################################################################
1348
# ###########################################################################
1349
# Percona::WebAPI::Resource::Service package
1350
# This package is a copy without comments from the original. The original
1351
# with comments and its test file can be found in the Bazaar repository at,
1352
# lib/Percona/WebAPI/Resource/Service.pm
1353
# t/lib/Percona/WebAPI/Resource/Service.t
1354
# See https://launchpad.net/percona-toolkit for more information.
1355
# ###########################################################################
1357
package Percona::WebAPI::Resource::Service;
1375
isa => 'ArrayRef[Percona::WebAPI::Resource::Task]',
1379
has 'run_schedule' => (
1385
has 'spool_schedule' => (
1395
default => sub { return 0 },
1402
default => sub { return 0 },
1407
isa => 'Maybe[HashRef]',
1409
default => sub { return {} },
1413
my ($class, %args) = @_;
1414
if ( ref $args{tasks} eq 'ARRAY' ) {
1416
foreach my $run_hashref ( @{$args{tasks}} ) {
1417
my $task = Percona::WebAPI::Resource::Task->new(%$run_hashref);
1420
$args{tasks} = \@tasks;
1422
return $class->SUPER::BUILDARGS(%args);
1428
# ###########################################################################
1429
# End Percona::WebAPI::Resource::Service package
1430
# ###########################################################################
1432
# ###########################################################################
1433
# Percona::WebAPI::Resource::Task package
1434
# This package is a copy without comments from the original. The original
1435
# with comments and its test file can be found in the Bazaar repository at,
1436
# lib/Percona/WebAPI/Resource/Task.pm
1437
# t/lib/Percona/WebAPI/Resource/Task.t
1438
# See https://launchpad.net/percona-toolkit for more information.
1439
# ###########################################################################
1441
package Percona::WebAPI::Resource::Task;
1459
isa => 'Maybe[Str]',
1465
isa => 'Maybe[Str]',
1471
isa => 'Maybe[Str]',
1475
sub TO_JSON { return { %{ shift() } }; }
1480
# ###########################################################################
1481
# End Percona::WebAPI::Resource::Task package
1482
# ###########################################################################
1484
# ###########################################################################
1485
# Percona::WebAPI::Resource::LogEntry package
1486
# This package is a copy without comments from the original. The original
1487
# with comments and its test file can be found in the Bazaar repository at,
1488
# lib/Percona/WebAPI/Resource/LogEntry.pm
1489
# t/lib/Percona/WebAPI/Resource/LogEntry.t
1490
# See https://launchpad.net/percona-toolkit for more information.
1491
# ###########################################################################
1493
package Percona::WebAPI::Resource::LogEntry;
1521
has 'log_level' => (
1536
# ###########################################################################
1537
# End Percona::WebAPI::Resource::LogEntry package
1538
# ###########################################################################
1540
# ###########################################################################
1541
# VersionCheck package
1542
# This package is a copy without comments from the original. The original
1543
# with comments and its test file can be found in the Bazaar repository at,
1544
# lib/VersionCheck.pm
1545
# t/lib/VersionCheck.t
1546
# See https://launchpad.net/percona-toolkit for more information.
1547
# ###########################################################################
1549
package VersionCheck;
1553
use warnings FATAL => 'all';
1554
use English qw(-no_match_vars);
1556
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1559
local $Data::Dumper::Indent = 1;
1560
local $Data::Dumper::Sortkeys = 1;
1561
local $Data::Dumper::Quotekeys = 0;
1563
use Digest::MD5 qw(md5_hex);
1564
use Sys::Hostname qw(hostname);
1565
use File::Basename qw();
1570
require Percona::Toolkit;
1571
require HTTP::Micro;
1575
my $file = 'percona-version-check';
1576
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
1579
'/etc/percona-toolkit',
1584
sub version_check_file {
1585
foreach my $dir ( @vc_dirs ) {
1586
if ( -d $dir && -w $dir ) {
1587
PTDEBUG && _d('Version check file', $file, 'in', $dir);
1588
return $dir . '/' . $file;
1591
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
1592
return $file; # in the CWD
1596
sub version_check_time_limit {
1597
return 60 * 60 * 24; # one day
1604
my $instances = $args{instances} || [];
1605
my $instances_to_check;
1607
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
1608
if ( !$args{force} ) {
1610
&& (-d "$FindBin::Bin/../.bzr" || -d "$FindBin::Bin/../../.bzr") ) {
1611
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
1617
foreach my $instance ( @$instances ) {
1618
my ($name, $id) = get_instance_id($instance);
1619
$instance->{name} = $name;
1620
$instance->{id} = $id;
1623
push @$instances, { name => 'system', id => 0 };
1625
$instances_to_check = get_instances_to_check(
1626
instances => $instances,
1627
vc_file => $args{vc_file}, # testing
1628
now => $args{now}, # testing
1630
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
1631
return unless @$instances_to_check;
1633
my $protocol = 'https'; # optimistic, but...
1634
eval { require IO::Socket::SSL; };
1635
if ( $EVAL_ERROR ) {
1636
PTDEBUG && _d($EVAL_ERROR);
1639
PTDEBUG && _d('Using', $protocol);
1641
my $advice = pingback(
1642
instances => $instances_to_check,
1643
protocol => $protocol,
1644
url => $args{url} # testing
1645
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
1646
|| "$protocol://v.percona.com",
1649
PTDEBUG && _d('Advice:', Dumper($advice));
1650
if ( scalar @$advice > 1) {
1651
print "\n# " . scalar @$advice . " software updates are "
1655
print "\n# A software update is available:\n";
1657
print join("\n", map { "# * $_" } @$advice), "\n\n";
1660
if ( $EVAL_ERROR ) {
1661
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
1664
if ( @$instances_to_check ) {
1667
instances => $instances_to_check,
1668
vc_file => $args{vc_file}, # testing
1669
now => $args{now}, # testing
1672
if ( $EVAL_ERROR ) {
1673
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
1677
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
1678
warn "Exiting because the PTDEBUG_VERSION_CHECK "
1679
. "environment variable is defined.\n";
1686
sub get_instances_to_check {
1689
my $instances = $args{instances};
1690
my $now = $args{now} || int(time);
1691
my $vc_file = $args{vc_file} || version_check_file();
1693
if ( !-f $vc_file ) {
1694
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
1695
'version checking all instances');
1699
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
1700
chomp(my $file_contents = do { local $/ = undef; <$fh> });
1701
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
1703
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
1705
my $check_time_limit = version_check_time_limit();
1706
my @instances_to_check;
1707
foreach my $instance ( @$instances ) {
1708
my $last_check_time = $last_check_time_for{ $instance->{id} };
1709
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
1710
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
1711
'hours until next check',
1713
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
1714
if ( !defined $last_check_time
1715
|| ($now - $last_check_time) >= $check_time_limit ) {
1716
PTDEBUG && _d('Time to check', Dumper($instance));
1717
push @instances_to_check, $instance;
1721
return \@instances_to_check;
1724
sub update_check_times {
1727
my $instances = $args{instances};
1728
my $now = $args{now} || int(time);
1729
my $vc_file = $args{vc_file} || version_check_file();
1730
PTDEBUG && _d('Updating last check time:', $now);
1732
my %all_instances = map {
1733
$_->{id} => { name => $_->{name}, ts => $now }
1736
if ( -f $vc_file ) {
1737
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
1738
my $contents = do { local $/ = undef; <$fh> };
1741
foreach my $line ( split("\n", ($contents || '')) ) {
1742
my ($id, $ts) = split(',', $line);
1743
if ( !exists $all_instances{$id} ) {
1744
$all_instances{$id} = { ts => $ts }; # original ts, not updated
1749
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
1750
foreach my $id ( sort keys %all_instances ) {
1751
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
1752
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
1759
sub get_instance_id {
1760
my ($instance) = @_;
1762
my $dbh = $instance->{dbh};
1763
my $dsn = $instance->{dsn};
1765
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
1766
PTDEBUG && _d($sql);
1767
my ($name) = eval { $dbh->selectrow_array($sql) };
1768
if ( $EVAL_ERROR ) {
1769
PTDEBUG && _d($EVAL_ERROR);
1770
$sql = q{SELECT @@hostname};
1771
PTDEBUG && _d($sql);
1772
($name) = eval { $dbh->selectrow_array($sql) };
1773
if ( $EVAL_ERROR ) {
1774
PTDEBUG && _d($EVAL_ERROR);
1775
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
1778
$sql = q{SHOW VARIABLES LIKE 'port'};
1779
PTDEBUG && _d($sql);
1780
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
1781
PTDEBUG && _d('port:', $port);
1782
$name .= $port || '';
1785
my $id = md5_hex($name);
1787
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
1795
my @required_args = qw(url instances);
1796
foreach my $arg ( @required_args ) {
1797
die "I need a $arg arugment" unless $args{$arg};
1799
my $url = $args{url};
1800
my $instances = $args{instances};
1802
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
1804
my $response = $ua->request('GET', $url);
1805
PTDEBUG && _d('Server response:', Dumper($response));
1806
die "No response from GET $url"
1808
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
1809
($response->{content} || '')) if $response->{status} != 200;
1810
die("GET on $url did not return any programs to check")
1811
if !$response->{content};
1813
my $items = parse_server_response(
1814
response => $response->{content}
1816
die "Failed to parse server requested programs: $response->{content}"
1817
if !scalar keys %$items;
1819
my $versions = get_versions(
1821
instances => $instances,
1823
die "Failed to get any program versions; should have at least gotten Perl"
1824
if !scalar keys %$versions;
1826
my $client_content = encode_client_response(
1828
versions => $versions,
1829
general_id => md5_hex( hostname() ),
1832
my $client_response = {
1833
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
1834
content => $client_content,
1836
PTDEBUG && _d('Client response:', Dumper($client_response));
1838
$response = $ua->request('POST', $url, $client_response);
1839
PTDEBUG && _d('Server suggestions:', Dumper($response));
1840
die "No response from POST $url $client_response"
1842
die "POST $url returned HTTP status $response->{status}; expected 200"
1843
if $response->{status} != 200;
1845
return unless $response->{content};
1847
$items = parse_server_response(
1848
response => $response->{content},
1851
die "Failed to parse server suggestions: $response->{content}"
1852
if !scalar keys %$items;
1853
my @suggestions = map { $_->{vars} }
1854
sort { $a->{item} cmp $b->{item} }
1857
return \@suggestions;
1860
sub encode_client_response {
1862
my @required_args = qw(items versions general_id);
1863
foreach my $arg ( @required_args ) {
1864
die "I need a $arg arugment" unless $args{$arg};
1866
my ($items, $versions, $general_id) = @args{@required_args};
1869
foreach my $item ( sort keys %$items ) {
1870
next unless exists $versions->{$item};
1871
if ( ref($versions->{$item}) eq 'HASH' ) {
1872
my $mysql_versions = $versions->{$item};
1873
for my $id ( sort keys %$mysql_versions ) {
1874
push @lines, join(';', $id, $item, $mysql_versions->{$id});
1878
push @lines, join(';', $general_id, $item, $versions->{$item});
1882
my $client_response = join("\n", @lines) . "\n";
1883
return $client_response;
1886
sub parse_server_response {
1888
my @required_args = qw(response);
1889
foreach my $arg ( @required_args ) {
1890
die "I need a $arg arugment" unless $args{$arg};
1892
my ($response) = @args{@required_args};
1895
my ($item, $type, $vars) = split(";", $_);
1896
if ( !defined $args{split_vars} || $args{split_vars} ) {
1897
$vars = [ split(",", ($vars || '')) ];
1904
} split("\n", $response);
1906
PTDEBUG && _d('Items:', Dumper(\%items));
1911
my %sub_for_type = (
1912
os_version => \&get_os_version,
1913
perl_version => \&get_perl_version,
1914
perl_module_version => \&get_perl_module_version,
1915
mysql_variable => \&get_mysql_variable,
1920
return unless $item;
1921
if ( !exists $sub_for_type{ $item->{type} } ) {
1922
PTDEBUG && _d('Invalid type:', $item->{type});
1930
my @required_args = qw(items);
1931
foreach my $arg ( @required_args ) {
1932
die "I need a $arg arugment" unless $args{$arg};
1934
my ($items) = @args{@required_args};
1937
foreach my $item ( values %$items ) {
1938
next unless valid_item($item);
1940
my $version = $sub_for_type{ $item->{type} }->(
1942
instances => $args{instances},
1945
chomp $version unless ref($version);
1946
$versions{$item->{item}} = $version;
1949
if ( $EVAL_ERROR ) {
1950
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
1958
sub get_os_version {
1959
if ( $OSNAME eq 'MSWin32' ) {
1961
return Win32::GetOSDisplayName();
1964
chomp(my $platform = `uname -s`);
1965
PTDEBUG && _d('platform:', $platform);
1966
return $OSNAME unless $platform;
1968
chomp(my $lsb_release
1969
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
1970
PTDEBUG && _d('lsb_release:', $lsb_release);
1974
if ( $platform eq 'Linux' ) {
1975
if ( -f "/etc/fedora-release" ) {
1976
$release = `cat /etc/fedora-release`;
1978
elsif ( -f "/etc/redhat-release" ) {
1979
$release = `cat /etc/redhat-release`;
1981
elsif ( -f "/etc/system-release" ) {
1982
$release = `cat /etc/system-release`;
1984
elsif ( $lsb_release ) {
1985
$release = `$lsb_release -ds`;
1987
elsif ( -f "/etc/lsb-release" ) {
1988
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
1989
$release =~ s/^\w+="([^"]+)".+/$1/;
1991
elsif ( -f "/etc/debian_version" ) {
1992
chomp(my $rel = `cat /etc/debian_version`);
1993
$release = "Debian $rel";
1994
if ( -f "/etc/apt/sources.list" ) {
1995
chomp(my $code_name = `awk '/^deb/ {print \$3}' /etc/apt/sources.list | awk -F/ '{print \$1}'| awk 'BEGIN {FS="|"} {print \$1}' | sort | uniq -c | sort -rn | head -n1 | awk '{print \$2}'`);
1996
$release .= " ($code_name)" if $code_name;
1999
elsif ( -f "/etc/os-release" ) { # openSUSE
2000
chomp($release = `grep PRETTY_NAME /etc/os-release`);
2001
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
2003
elsif ( `ls /etc/*release 2>/dev/null` ) {
2004
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
2005
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
2008
$release = `cat /etc/*release | head -n1`;
2012
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
2013
my $rel = `uname -r`;
2014
$release = "$platform $rel";
2016
elsif ( $platform eq "SunOS" ) {
2017
my $rel = `head -n1 /etc/release` || `uname -r`;
2018
$release = "$platform $rel";
2022
PTDEBUG && _d('Failed to get the release, using platform');
2023
$release = $platform;
2027
$release =~ s/^"|"$//g;
2029
PTDEBUG && _d('OS version =', $release);
2033
sub get_perl_version {
2035
my $item = $args{item};
2036
return unless $item;
2038
my $version = sprintf '%vd', $PERL_VERSION;
2039
PTDEBUG && _d('Perl version', $version);
2043
sub get_perl_module_version {
2045
my $item = $args{item};
2046
return unless $item;
2048
my $var = '$' . $item->{item} . '::VERSION';
2049
my $version = eval "use $item->{item}; $var;";
2050
PTDEBUG && _d('Perl version for', $var, '=', $version);
2054
sub get_mysql_variable {
2055
return get_from_mysql(
2056
show => 'VARIABLES',
2061
sub get_from_mysql {
2063
my $show = $args{show};
2064
my $item = $args{item};
2065
my $instances = $args{instances};
2066
return unless $show && $item;
2068
if ( !$instances || !@$instances ) {
2069
PTDEBUG && _d('Cannot check', $item,
2070
'because there are no MySQL instances');
2076
foreach my $instance ( @$instances ) {
2077
next unless $instance->{id}; # special system instance has id=0
2078
my $dbh = $instance->{dbh};
2079
local $dbh->{FetchHashKeyName} = 'NAME_lc';
2080
my $sql = qq/SHOW $show/;
2081
PTDEBUG && _d($sql);
2082
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
2085
foreach my $var ( @{$item->{vars}} ) {
2087
my $version = $rows->{$var}->{value};
2088
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
2089
'on', $instance->{name});
2090
push @versions, $version;
2092
$version_for{ $instance->{id} } = join(' ', @versions);
2095
return \%version_for;
2099
my ($package, undef, $line) = caller 0;
2100
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2101
map { defined $_ ? $_ : 'undef' }
2103
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2108
# ###########################################################################
2109
# End VersionCheck package
2110
# ###########################################################################
2112
# ###########################################################################
2114
# This package is a copy without comments from the original. The original
2115
# with comments and its test file can be found in the Bazaar repository at,
2118
# See https://launchpad.net/percona-toolkit for more information.
2119
# ###########################################################################
2124
use warnings FATAL => 'all';
2125
use English qw(-no_match_vars);
2126
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2129
$Data::Dumper::Indent = 0;
2130
$Data::Dumper::Quotekeys = 0;
2132
my $dsn_sep = qr/(?<!\\),/;
2137
my $have_dbi = $EVAL_ERROR ? 0 : 1;
2140
my ( $class, %args ) = @_;
2141
foreach my $arg ( qw(opts) ) {
2142
die "I need a $arg argument" unless $args{$arg};
2145
opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
2147
foreach my $opt ( @{$args{opts}} ) {
2148
if ( !$opt->{key} || !$opt->{desc} ) {
2149
die "Invalid DSN option: ", Dumper($opt);
2151
PTDEBUG && _d('DSN option:',
2153
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
2157
$self->{opts}->{$opt->{key}} = {
2159
desc => $opt->{desc},
2160
copy => $opt->{copy} || 0,
2163
return bless $self, $class;
2167
my ( $self, $prop, $value ) = @_;
2169
PTDEBUG && _d('Setting', $prop, 'property');
2170
$self->{$prop} = $value;
2172
return $self->{$prop};
2176
my ( $self, $dsn, $prev, $defaults ) = @_;
2178
PTDEBUG && _d('No DSN to parse');
2181
PTDEBUG && _d('Parsing', $dsn);
2186
my $opts = $self->{opts};
2188
foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
2189
$dsn_part =~ s/\\,/,/g;
2190
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
2191
$given_props{$prop_key} = $prop_val;
2194
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
2195
$given_props{h} = $dsn_part;
2199
foreach my $key ( keys %$opts ) {
2200
PTDEBUG && _d('Finding value for', $key);
2201
$final_props{$key} = $given_props{$key};
2202
if ( !defined $final_props{$key}
2203
&& defined $prev->{$key} && $opts->{$key}->{copy} )
2205
$final_props{$key} = $prev->{$key};
2206
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
2208
if ( !defined $final_props{$key} ) {
2209
$final_props{$key} = $defaults->{$key};
2210
PTDEBUG && _d('Copying value for', $key, 'from defaults');
2214
foreach my $key ( keys %given_props ) {
2215
die "Unknown DSN option '$key' in '$dsn'. For more details, "
2216
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
2217
. "for complete documentation."
2218
unless exists $opts->{$key};
2220
if ( (my $required = $self->prop('required')) ) {
2221
foreach my $key ( keys %$required ) {
2222
die "Missing required DSN option '$key' in '$dsn'. For more details, "
2223
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
2224
. "for complete documentation."
2225
unless $final_props{$key};
2229
return \%final_props;
2233
my ( $self, $o ) = @_;
2234
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
2237
map { "$_=".$o->get($_); }
2238
grep { $o->has($_) && $o->get($_) }
2239
keys %{$self->{opts}}
2241
PTDEBUG && _d('DSN string made from options:', $dsn_string);
2242
return $self->parse($dsn_string);
2246
my ( $self, $dsn, $props ) = @_;
2247
return $dsn unless ref $dsn;
2248
my @keys = $props ? @$props : sort keys %$dsn;
2250
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
2252
exists $self->{opts}->{$_}
2253
&& exists $dsn->{$_}
2254
&& defined $dsn->{$_}
2261
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
2262
. " KEY COPY MEANING\n"
2263
. " === ==== =============================================\n";
2264
my %opts = %{$self->{opts}};
2265
foreach my $key ( sort keys %opts ) {
2267
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
2268
. ($opts{$key}->{desc} || '[No description]')
2271
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
2275
sub get_cxn_params {
2276
my ( $self, $info ) = @_;
2278
my %opts = %{$self->{opts}};
2279
my $driver = $self->prop('dbidriver') || '';
2280
if ( $driver eq 'Pg' ) {
2281
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
2282
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
2283
grep { defined $info->{$_} }
2287
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
2288
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
2289
grep { defined $info->{$_} }
2291
. ';mysql_read_default_group=client'
2292
. ($info->{L} ? ';mysql_local_infile=1' : '');
2294
PTDEBUG && _d($dsn);
2295
return ($dsn, $info->{u}, $info->{p});
2299
my ( $self, $dbh, $dsn ) = @_;
2300
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
2301
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
2303
$dsn->{h} ||= $vars->{hostname}->{Value};
2304
$dsn->{S} ||= $vars->{'socket'}->{Value};
2305
$dsn->{P} ||= $vars->{port}->{Value};
2306
$dsn->{u} ||= $user;
2311
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
2317
ShowErrorStatement => 1,
2318
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
2320
@{$defaults}{ keys %$opts } = values %$opts;
2321
if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
2322
$defaults->{mysql_local_infile} = 1;
2325
if ( $opts->{mysql_use_result} ) {
2326
$defaults->{mysql_use_result} = 1;
2330
die "Cannot connect to MySQL because the Perl DBI module is not "
2331
. "installed or not found. Run 'perl -MDBI' to see the directories "
2332
. "that Perl searches for DBI. If DBI is not installed, try:\n"
2333
. " Debian/Ubuntu apt-get install libdbi-perl\n"
2334
. " RHEL/CentOS yum install perl-DBI\n"
2335
. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
2341
while ( !$dbh && $tries-- ) {
2342
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
2343
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
2345
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
2347
if ( !$dbh && $EVAL_ERROR ) {
2348
if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
2349
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
2350
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
2351
. "the directories that Perl searches for DBD::mysql. If "
2352
. "DBD::mysql is not installed, try:\n"
2353
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
2354
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
2355
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
2357
elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
2358
PTDEBUG && _d('Going to try again without utf8 support');
2359
delete $defaults->{mysql_enable_utf8};
2367
if ( $cxn_string =~ m/mysql/i ) {
2370
$sql = 'SELECT @@SQL_MODE';
2371
PTDEBUG && _d($dbh, $sql);
2372
my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
2373
if ( $EVAL_ERROR ) {
2374
die "Error getting the current SQL_MODE: $EVAL_ERROR";
2377
if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
2378
$sql = qq{/*!40101 SET NAMES "$charset"*/};
2379
PTDEBUG && _d($dbh, $sql);
2380
eval { $dbh->do($sql) };
2381
if ( $EVAL_ERROR ) {
2382
die "Error setting NAMES to $charset: $EVAL_ERROR";
2384
PTDEBUG && _d('Enabling charset for STDOUT');
2385
if ( $charset eq 'utf8' ) {
2386
binmode(STDOUT, ':utf8')
2387
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
2390
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
2394
if ( my $vars = $self->prop('set-vars') ) {
2395
$self->set_vars($dbh, $vars);
2398
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
2399
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
2400
. ($sql_mode ? ",$sql_mode" : '')
2402
PTDEBUG && _d($dbh, $sql);
2403
eval { $dbh->do($sql) };
2404
if ( $EVAL_ERROR ) {
2405
die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
2406
. ($sql_mode ? " and $sql_mode" : '')
2411
PTDEBUG && _d('DBH info: ',
2413
Dumper($dbh->selectrow_hashref(
2414
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
2415
'Connection info:', $dbh->{mysql_hostinfo},
2416
'Character set info:', Dumper($dbh->selectall_arrayref(
2417
"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
2418
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
2419
'$DBI::VERSION:', $DBI::VERSION,
2426
my ( $self, $dbh ) = @_;
2427
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
2430
my ( $hostname, $one ) = $dbh->selectrow_array(
2431
'SELECT /*!50038 @@hostname, */ 1');
2436
my ( $self, $dbh ) = @_;
2437
PTDEBUG && $self->print_active_handles($dbh);
2441
sub print_active_handles {
2442
my ( $self, $thing, $level ) = @_;
2444
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
2445
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
2446
or die "Cannot print: $OS_ERROR";
2447
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
2448
$self->print_active_handles( $handle, $level + 1 );
2453
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
2454
die 'I need a dsn_1 argument' unless $dsn_1;
2455
die 'I need a dsn_2 argument' unless $dsn_2;
2459
if ( $args{overwrite} ) {
2460
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
2463
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
2466
} keys %{$self->{opts}};
2471
my ($self, $dbh, $vars) = @_;
2473
return unless $vars;
2475
foreach my $var ( sort keys %$vars ) {
2476
my $val = $vars->{$var}->{val};
2478
(my $quoted_var = $var) =~ s/_/\\_/;
2479
my ($var_exists, $current_val);
2481
($var_exists, $current_val) = $dbh->selectrow_array(
2482
"SHOW VARIABLES LIKE '$quoted_var'");
2484
my $e = $EVAL_ERROR;
2489
if ( $vars->{$var}->{default} && !$var_exists ) {
2490
PTDEBUG && _d('Not setting default var', $var,
2491
'because it does not exist');
2495
if ( $current_val && $current_val eq $val ) {
2496
PTDEBUG && _d('Not setting var', $var, 'because its value',
2497
'is already', $val);
2501
my $sql = "SET SESSION $var=$val";
2502
PTDEBUG && _d($dbh, $sql);
2503
eval { $dbh->do($sql) };
2504
if ( my $set_error = $EVAL_ERROR ) {
2506
$set_error =~ s/ at \S+ line \d+//;
2507
my $msg = "Error setting $var: $set_error";
2508
if ( $current_val ) {
2509
$msg .= " The current value for $var is $current_val. "
2510
. "If the variable is read only (not dynamic), specify "
2511
. "--set-vars $var=$current_val to avoid this warning, "
2512
. "else manually set the variable and restart MySQL.";
2522
my ($package, undef, $line) = caller 0;
2523
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2524
map { defined $_ ? $_ : 'undef' }
2526
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2531
# ###########################################################################
2532
# End DSNParser package
2533
# ###########################################################################
2535
# ###########################################################################
2536
# OptionParser package
2537
# This package is a copy without comments from the original. The original
2538
# with comments and its test file can be found in the Bazaar repository at,
2539
# lib/OptionParser.pm
2540
# t/lib/OptionParser.t
2541
# See https://launchpad.net/percona-toolkit for more information.
2542
# ###########################################################################
2544
package OptionParser;
2547
use warnings FATAL => 'all';
2548
use English qw(-no_match_vars);
2549
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2551
use List::Util qw(max);
2555
my $POD_link_re = '[LC]<"?([^">]+)"?>';
2558
my ( $class, %args ) = @_;
2559
my @required_args = qw();
2560
foreach my $arg ( @required_args ) {
2561
die "I need a $arg argument" unless $args{$arg};
2564
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
2565
$program_name ||= $PROGRAM_NAME;
2566
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
2578
head1 => 'OPTIONS', # These args are used internally
2579
skip_rules => 0, # to instantiate another Option-
2580
item => '--(.*)', # Parser obj that parses the
2581
attributes => \%attributes, # DSN OPTIONS section. Tools
2582
parse_attributes => \&_parse_attribs, # don't tinker with these args.
2586
strict => 1, # disabled by a special rule
2587
program_name => $program_name,
2593
allowed_groups => {},
2595
rules => [], # desc of rules for --help
2596
mutex => [], # rule: opts are mutually exclusive
2597
atleast1 => [], # rule: at least one opt is required
2598
disables => {}, # rule: opt disables other opts
2599
defaults_to => {}, # rule: opt defaults to value of other opt
2602
"/etc/percona-toolkit/percona-toolkit.conf",
2603
"/etc/percona-toolkit/$program_name.conf",
2604
"$home/.percona-toolkit.conf",
2605
"$home/.$program_name.conf",
2608
string => 's', # standard Getopt type
2609
int => 'i', # standard Getopt type
2610
float => 'f', # standard Getopt type
2611
Hash => 'H', # hash, formed from a comma-separated list
2612
hash => 'h', # hash as above, but only if a value is given
2613
Array => 'A', # array, similar to Hash
2614
array => 'a', # array, similar to hash
2616
size => 'z', # size with kMG suffix (powers of 2^10)
2617
time => 'm', # time, with an optional suffix of s/h/m/d
2621
return bless $self, $class;
2625
my ( $self, $file ) = @_;
2626
$file ||= $self->{file} || __FILE__;
2627
my @specs = $self->_pod_to_specs($file);
2628
$self->_parse_specs(@specs);
2630
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
2631
my $contents = do { local $/ = undef; <$fh> };
2633
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
2634
PTDEBUG && _d('Parsing DSN OPTIONS');
2639
my $parse_dsn_attribs = sub {
2640
my ( $self, $option, $attribs ) = @_;
2642
my $val = $attribs->{$_};
2644
$val = $val eq 'yes' ? 1
2647
$attribs->{$_} = $val;
2655
my $dsn_o = new OptionParser(
2656
description => 'DSN OPTIONS',
2657
head1 => 'DSN OPTIONS',
2658
dsn => 0, # XXX don't infinitely recurse!
2659
item => '\* (.)', # key opts are a single character
2660
skip_rules => 1, # no rules before opts
2661
attributes => $dsn_attribs,
2662
parse_attributes => $parse_dsn_attribs,
2664
my @dsn_opts = map {
2666
key => $_->{spec}->{key},
2667
dsn => $_->{spec}->{dsn},
2668
copy => $_->{spec}->{copy},
2672
} $dsn_o->_pod_to_specs($file);
2673
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
2676
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
2677
$self->{version} = $1;
2678
PTDEBUG && _d($self->{version});
2686
return $self->{DSNParser};
2689
sub get_defaults_files {
2691
return @{$self->{default_files}};
2695
my ( $self, $file ) = @_;
2696
$file ||= $self->{file} || __FILE__;
2697
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
2703
local $INPUT_RECORD_SEPARATOR = '';
2704
while ( $para = <$fh> ) {
2705
next unless $para =~ m/^=head1 $self->{head1}/;
2709
while ( $para = <$fh> ) {
2710
last if $para =~ m/^=over/;
2711
next if $self->{skip_rules};
2714
$para =~ s/$POD_link_re/$1/go;
2715
PTDEBUG && _d('Option rule:', $para);
2719
die "POD has no $self->{head1} section" unless $para;
2722
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
2724
PTDEBUG && _d($para);
2727
$para = <$fh>; # read next paragraph, possibly attributes
2729
if ( $para =~ m/: / ) { # attributes
2730
$para =~ s/\s+\Z//g;
2732
my ( $attrib, $val) = split(/: /, $_);
2733
die "Unrecognized attribute for --$option: $attrib"
2734
unless $self->{attributes}->{$attrib};
2736
} split(/; /, $para);
2737
if ( $attribs{'short form'} ) {
2738
$attribs{'short form'} =~ s/-//;
2740
$para = <$fh>; # read next paragraph, probably short help desc
2743
PTDEBUG && _d('Option has no attributes');
2746
$para =~ s/\s+\Z//g;
2748
$para =~ s/$POD_link_re/$1/go;
2750
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
2751
PTDEBUG && _d('Short help:', $para);
2753
die "No description after option spec $option" if $para =~ m/^=item/;
2755
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
2756
$option = $base_option;
2757
$attribs{'negatable'} = 1;
2761
spec => $self->{parse_attributes}->($self, $option, \%attribs),
2763
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
2764
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
2767
while ( $para = <$fh> ) {
2769
if ( $para =~ m/^=head1/ ) {
2770
$para = undef; # Can't 'last' out of a do {} block.
2773
last if $para =~ m/^=item /;
2777
die "No valid specs in $self->{head1}" unless @specs;
2780
return @specs, @rules;
2784
my ( $self, @specs ) = @_;
2785
my %disables; # special rule that requires deferred checking
2787
foreach my $opt ( @specs ) {
2788
if ( ref $opt ) { # It's an option spec, not a rule.
2789
PTDEBUG && _d('Parsing opt spec:',
2790
map { ($_, '=>', $opt->{$_}) } keys %$opt);
2792
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
2794
die "Cannot parse long option from spec $opt->{spec}";
2796
$opt->{long} = $long;
2798
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
2799
$self->{opts}->{$long} = $opt;
2801
if ( length $long == 1 ) {
2802
PTDEBUG && _d('Long opt', $long, 'looks like short opt');
2803
$self->{short_opts}->{$long} = $long;
2807
die "Duplicate short option -$short"
2808
if exists $self->{short_opts}->{$short};
2809
$self->{short_opts}->{$short} = $long;
2810
$opt->{short} = $short;
2813
$opt->{short} = undef;
2816
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
2817
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
2818
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
2820
$opt->{group} ||= 'default';
2821
$self->{groups}->{ $opt->{group} }->{$long} = 1;
2823
$opt->{value} = undef;
2826
my ( $type ) = $opt->{spec} =~ m/=(.)/;
2827
$opt->{type} = $type;
2828
PTDEBUG && _d($long, 'type:', $type);
2831
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
2833
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
2834
$self->{defaults}->{$long} = defined $def ? $def : 1;
2835
PTDEBUG && _d($long, 'default:', $def);
2838
if ( $long eq 'config' ) {
2839
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
2842
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
2843
$disables{$long} = $dis;
2844
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
2847
$self->{opts}->{$long} = $opt;
2849
else { # It's an option rule, not a spec.
2850
PTDEBUG && _d('Parsing rule:', $opt);
2851
push @{$self->{rules}}, $opt;
2852
my @participants = $self->_get_participants($opt);
2855
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
2857
push @{$self->{mutex}}, \@participants;
2858
PTDEBUG && _d(@participants, 'are mutually exclusive');
2860
if ( $opt =~ m/at least one|one and only one/ ) {
2862
push @{$self->{atleast1}}, \@participants;
2863
PTDEBUG && _d(@participants, 'require at least one');
2865
if ( $opt =~ m/default to/ ) {
2867
$self->{defaults_to}->{$participants[0]} = $participants[1];
2868
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
2870
if ( $opt =~ m/restricted to option groups/ ) {
2872
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
2873
my @groups = split(',', $groups);
2874
%{$self->{allowed_groups}->{$participants[0]}} = map {
2879
if( $opt =~ m/accepts additional command-line arguments/ ) {
2881
$self->{strict} = 0;
2882
PTDEBUG && _d("Strict mode disabled by rule");
2885
die "Unrecognized option rule: $opt" unless $rule_ok;
2889
foreach my $long ( keys %disables ) {
2890
my @participants = $self->_get_participants($disables{$long});
2891
$self->{disables}->{$long} = \@participants;
2892
PTDEBUG && _d('Option', $long, 'disables', @participants);
2898
sub _get_participants {
2899
my ( $self, $str ) = @_;
2901
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
2902
die "Option --$long does not exist while processing rule $str"
2903
unless exists $self->{opts}->{$long};
2904
push @participants, $long;
2906
PTDEBUG && _d('Participants for', $str, ':', @participants);
2907
return @participants;
2912
my %opts = %{$self->{opts}};
2918
my %short_opts = %{$self->{short_opts}};
2923
my ( $self, %defaults ) = @_;
2924
$self->{defaults} = {};
2925
foreach my $long ( keys %defaults ) {
2926
die "Cannot set default for nonexistent option $long"
2927
unless exists $self->{opts}->{$long};
2928
$self->{defaults}->{$long} = $defaults{$long};
2929
PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
2936
return $self->{defaults};
2941
return $self->{groups};
2945
my ( $self, $opt, $val ) = @_;
2946
my $long = exists $self->{opts}->{$opt} ? $opt
2947
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
2948
: die "Getopt::Long gave a nonexistent option: $opt";
2949
$opt = $self->{opts}->{$long};
2950
if ( $opt->{is_cumulative} ) {
2953
elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
2955
if ( exists $self->{opts}->{$next_opt}
2956
|| exists $self->{short_opts}->{$next_opt} ) {
2957
$self->save_error("--$long requires a string value");
2961
$opt->{value} = $val;
2965
$opt->{value} = $val;
2968
PTDEBUG && _d('Got option', $long, '=', $val);
2974
foreach my $long ( keys %{$self->{opts}} ) {
2975
$self->{opts}->{$long}->{got} = 0;
2976
$self->{opts}->{$long}->{value}
2977
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
2978
: $self->{opts}->{$long}->{is_cumulative} ? 0
2981
$self->{got_opts} = 0;
2983
$self->{errors} = [];
2985
if ( @ARGV && $ARGV[0] eq "--config" ) {
2987
$self->_set_option('config', shift @ARGV);
2989
if ( $self->has('config') ) {
2991
foreach my $filename ( split(',', $self->get('config')) ) {
2993
push @extra_args, $self->_read_config_file($filename);
2995
if ( $EVAL_ERROR ) {
2996
if ( $self->got('config') ) {
3004
unshift @ARGV, @extra_args;
3007
Getopt::Long::Configure('no_ignore_case', 'bundling');
3009
map { $_->{spec} => sub { $self->_set_option(@_); } }
3010
grep { $_->{long} ne 'config' } # --config is handled specially above.
3011
values %{$self->{opts}}
3012
) or $self->save_error('Error parsing options');
3014
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
3015
if ( $self->{version} ) {
3016
print $self->{version}, "\n";
3019
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
3024
if ( @ARGV && $self->{strict} ) {
3025
$self->save_error("Unrecognized command-line options @ARGV");
3028
foreach my $mutex ( @{$self->{mutex}} ) {
3029
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
3031
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
3032
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
3033
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
3034
. ' are mutually exclusive.';
3035
$self->save_error($err);
3039
foreach my $required ( @{$self->{atleast1}} ) {
3040
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
3042
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
3043
@{$required}[ 0 .. scalar(@$required) - 2] )
3044
.' or --'.$self->{opts}->{$required->[-1]}->{long};
3045
$self->save_error("Specify at least one of $err");
3049
$self->_check_opts( keys %{$self->{opts}} );
3050
$self->{got_opts} = 1;
3055
my ( $self, @long ) = @_;
3056
my $long_last = scalar @long;
3058
foreach my $i ( 0..$#long ) {
3059
my $long = $long[$i];
3061
my $opt = $self->{opts}->{$long};
3062
if ( $opt->{got} ) {
3063
if ( exists $self->{disables}->{$long} ) {
3064
my @disable_opts = @{$self->{disables}->{$long}};
3065
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
3066
PTDEBUG && _d('Unset options', @disable_opts,
3067
'because', $long,'disables them');
3070
if ( exists $self->{allowed_groups}->{$long} ) {
3072
my @restricted_groups = grep {
3073
!exists $self->{allowed_groups}->{$long}->{$_}
3074
} keys %{$self->{groups}};
3076
my @restricted_opts;
3077
foreach my $restricted_group ( @restricted_groups ) {
3079
foreach my $restricted_opt (
3080
keys %{$self->{groups}->{$restricted_group}} )
3082
next RESTRICTED_OPT if $restricted_opt eq $long;
3083
push @restricted_opts, $restricted_opt
3084
if $self->{opts}->{$restricted_opt}->{got};
3088
if ( @restricted_opts ) {
3090
if ( @restricted_opts == 1 ) {
3091
$err = "--$restricted_opts[0]";
3095
map { "--$self->{opts}->{$_}->{long}" }
3097
@restricted_opts[0..scalar(@restricted_opts) - 2]
3099
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
3101
$self->save_error("--$long is not allowed with $err");
3106
elsif ( $opt->{is_required} ) {
3107
$self->save_error("Required option --$long must be specified");
3110
$self->_validate_type($opt);
3111
if ( $opt->{parsed} ) {
3115
PTDEBUG && _d('Temporarily failed to parse', $long);
3119
die "Failed to parse options, possibly due to circular dependencies"
3120
if @long == $long_last;
3127
sub _validate_type {
3128
my ( $self, $opt ) = @_;
3131
if ( !$opt->{type} ) {
3136
my $val = $opt->{value};
3138
if ( $val && $opt->{type} eq 'm' ) { # type time
3139
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
3140
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
3142
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
3143
$suffix = $s || 's';
3144
PTDEBUG && _d('No suffix given; using', $suffix, 'for',
3145
$opt->{long}, '(value:', $val, ')');
3147
if ( $suffix =~ m/[smhd]/ ) {
3148
$val = $suffix eq 's' ? $num # Seconds
3149
: $suffix eq 'm' ? $num * 60 # Minutes
3150
: $suffix eq 'h' ? $num * 3600 # Hours
3151
: $num * 86400; # Days
3152
$opt->{value} = ($prefix || '') . $val;
3153
PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
3156
$self->save_error("Invalid time suffix for --$opt->{long}");
3159
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
3160
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
3162
my $from_key = $self->{defaults_to}->{ $opt->{long} };
3164
PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
3165
if ( $self->{opts}->{$from_key}->{parsed} ) {
3166
$prev = $self->{opts}->{$from_key}->{value};
3169
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
3170
$from_key, 'parsed');
3174
my $defaults = $self->{DSNParser}->parse_options($self);
3175
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
3177
elsif ( $val && $opt->{type} eq 'z' ) { # type size
3178
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
3179
$self->_parse_size($opt, $val);
3181
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
3182
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
3184
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
3185
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
3188
PTDEBUG && _d('Nothing to validate for option',
3189
$opt->{long}, 'type', $opt->{type}, 'value', $val);
3197
my ( $self, $opt ) = @_;
3198
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3199
die "Option $opt does not exist"
3200
unless $long && exists $self->{opts}->{$long};
3201
return $self->{opts}->{$long}->{value};
3205
my ( $self, $opt ) = @_;
3206
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3207
die "Option $opt does not exist"
3208
unless $long && exists $self->{opts}->{$long};
3209
return $self->{opts}->{$long}->{got};
3213
my ( $self, $opt ) = @_;
3214
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3215
return defined $long ? exists $self->{opts}->{$long} : 0;
3219
my ( $self, $opt, $val ) = @_;
3220
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3221
die "Option $opt does not exist"
3222
unless $long && exists $self->{opts}->{$long};
3223
$self->{opts}->{$long}->{value} = $val;
3228
my ( $self, $error ) = @_;
3229
push @{$self->{errors}}, $error;
3235
return $self->{errors};
3240
warn "No usage string is set" unless $self->{usage}; # XXX
3241
return "Usage: " . ($self->{usage} || '') . "\n";
3246
warn "No description string is set" unless $self->{description}; # XXX
3247
my $descr = ($self->{description} || $self->{program_name} || '')
3248
. " For more details, please use the --help option, "
3249
. "or try 'perldoc $PROGRAM_NAME' "
3250
. "for complete documentation.";
3251
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
3252
unless $ENV{DONT_BREAK_LINES};
3253
$descr =~ s/ +$//mg;
3257
sub usage_or_errors {
3258
my ( $self, $file, $return ) = @_;
3259
$file ||= $self->{file} || __FILE__;
3261
if ( !$self->{description} || !$self->{usage} ) {
3262
PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
3263
my %synop = $self->_parse_synopsis($file);
3264
$self->{description} ||= $synop{description};
3265
$self->{usage} ||= $synop{usage};
3266
PTDEBUG && _d("Description:", $self->{description},
3267
"\nUsage:", $self->{usage});
3270
if ( $self->{opts}->{help}->{got} ) {
3271
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
3272
exit 0 unless $return;
3274
elsif ( scalar @{$self->{errors}} ) {
3275
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
3276
exit 1 unless $return;
3284
my $usage = $self->usage() . "\n";
3285
if ( (my @errors = @{$self->{errors}}) ) {
3286
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
3289
return $usage . "\n" . $self->descr();
3294
die "Run get_opts() before print_usage()" unless $self->{got_opts};
3295
my @opts = values %{$self->{opts}};
3299
length($_->{long}) # option long name
3300
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
3301
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
3308
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
3309
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
3311
values %{$self->{short_opts}});
3313
my $lcol = max($maxl, ($maxs + 3));
3314
my $rcol = 80 - $lcol - 6;
3315
my $rpad = ' ' x ( 80 - $rcol );
3317
$maxs = max($lcol - 3, $maxs);
3319
my $usage = $self->descr() . "\n" . $self->usage();
3321
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
3322
push @groups, 'default';
3324
foreach my $group ( reverse @groups ) {
3325
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
3327
sort { $a->{long} cmp $b->{long} }
3328
grep { $_->{group} eq $group }
3331
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
3332
my $short = $opt->{short};
3333
my $desc = $opt->{desc};
3335
$long .= $opt->{type} ? "=$opt->{type}" : "";
3337
if ( $opt->{type} && $opt->{type} eq 'm' ) {
3338
my ($s) = $desc =~ m/\(suffix (.)\)/;
3340
$desc =~ s/\s+\(suffix .\)//;
3341
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
3342
. "d=days; if no suffix, $s is used.";
3344
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
3347
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
3350
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
3355
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
3357
if ( (my @rules = @{$self->{rules}}) ) {
3358
$usage .= "\nRules:\n\n";
3359
$usage .= join("\n", map { " $_" } @rules) . "\n";
3361
if ( $self->{DSNParser} ) {
3362
$usage .= "\n" . $self->{DSNParser}->usage();
3364
$usage .= "\nOptions and values after processing arguments:\n\n";
3365
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
3366
my $val = $opt->{value};
3367
my $type = $opt->{type} || '';
3368
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
3369
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
3370
: !defined $val ? '(No value)'
3371
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
3372
: $type =~ m/H|h/ ? join(',', sort keys %$val)
3373
: $type =~ m/A|a/ ? join(',', @$val)
3375
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
3381
shift @_ if ref $_[0] eq __PACKAGE__;
3382
my ( $prompt ) = @_;
3383
local $OUTPUT_AUTOFLUSH = 1;
3384
print STDERR $prompt
3385
or die "Cannot print: $OS_ERROR";
3388
require Term::ReadKey;
3389
Term::ReadKey::ReadMode('noecho');
3390
chomp($response = <STDIN>);
3391
Term::ReadKey::ReadMode('normal');
3393
or die "Cannot print: $OS_ERROR";
3395
if ( $EVAL_ERROR ) {
3396
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
3401
sub _read_config_file {
3402
my ( $self, $filename ) = @_;
3403
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
3409
while ( my $line = <$fh> ) {
3411
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
3412
$line =~ s/\s+#.*$//g;
3413
$line =~ s/^\s+|\s+$//g;
3414
if ( $line eq '--' ) {
3420
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
3422
push @args, grep { defined $_ } ("$prefix$opt", $arg);
3424
elsif ( $line =~ m/./ ) {
3428
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
3435
sub read_para_after {
3436
my ( $self, $file, $regex ) = @_;
3437
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
3438
local $INPUT_RECORD_SEPARATOR = '';
3440
while ( $para = <$fh> ) {
3441
next unless $para =~ m/^=pod$/m;
3444
while ( $para = <$fh> ) {
3445
next unless $para =~ m/$regex/;
3450
close $fh or die "Can't close $file: $OS_ERROR";
3458
my $hashref = $self->{$_};
3460
foreach my $key ( keys %$hashref ) {
3461
my $ref = ref $hashref->{$key};
3462
$val_copy->{$key} = !$ref ? $hashref->{$key}
3463
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
3464
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
3468
} qw(opts short_opts defaults);
3470
foreach my $scalar ( qw(got_opts) ) {
3471
$clone{$scalar} = $self->{$scalar};
3474
return bless \%clone;
3478
my ( $self, $opt, $val ) = @_;
3480
if ( lc($val || '') eq 'null' ) {
3481
PTDEBUG && _d('NULL size for', $opt->{long});
3482
$opt->{value} = 'null';
3486
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
3487
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
3488
if ( defined $num ) {
3490
$num *= $factor_for{$factor};
3491
PTDEBUG && _d('Setting option', $opt->{y},
3492
'to num', $num, '* factor', $factor);
3494
$opt->{value} = ($pre || '') . $num;
3497
$self->save_error("Invalid size for --$opt->{long}: $val");
3502
sub _parse_attribs {
3503
my ( $self, $option, $attribs ) = @_;
3504
my $types = $self->{types};
3506
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
3507
. ($attribs->{'negatable'} ? '!' : '' )
3508
. ($attribs->{'cumulative'} ? '+' : '' )
3509
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
3512
sub _parse_synopsis {
3513
my ( $self, $file ) = @_;
3514
$file ||= $self->{file} || __FILE__;
3515
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
3517
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
3518
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
3520
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
3521
die "$file does not contain a SYNOPSIS section" unless $para;
3523
for ( 1..2 ) { # 1 for the usage, 2 for the description
3528
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
3529
my ($usage, $desc) = @synop;
3530
die "The SYNOPSIS section in $file is not formatted properly"
3531
unless $usage && $desc;
3533
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
3537
$desc =~ s/\s{2,}/ /g;
3538
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
3542
description => $desc,
3548
my ($self, $file) = @_;
3549
$file ||= $self->{file} || __FILE__;
3552
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
3554
foreach my $var_val ( @$user_vars ) {
3555
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
3556
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
3557
$user_vars{$var} = {
3565
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
3566
if ( $default_vars ) {
3567
%default_vars = map {
3569
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
3570
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
3575
} split("\n", $default_vars);
3579
%default_vars, # first the tool's defaults
3580
%user_vars, # then the user's which overwrite the defaults
3582
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
3587
my ($package, undef, $line) = caller 0;
3588
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3589
map { defined $_ ? $_ : 'undef' }
3591
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3595
print STDERR '# ', $^X, ' ', $], "\n";
3596
if ( my $uname = `uname -a` ) {
3597
$uname =~ s/\s+/ /g;
3598
print STDERR "# $uname\n";
3600
print STDERR '# Arguments: ',
3601
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
3606
# ###########################################################################
3607
# End OptionParser package
3608
# ###########################################################################
3610
# ###########################################################################
3612
# This package is a copy without comments from the original. The original
3613
# with comments and its test file can be found in the Bazaar repository at,
3616
# See https://launchpad.net/percona-toolkit for more information.
3617
# ###########################################################################
3622
use warnings FATAL => 'all';
3623
use English qw(-no_match_vars);
3624
use Scalar::Util qw(blessed);
3626
PTDEBUG => $ENV{PTDEBUG} || 0,
3627
PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
3631
my ( $class, %args ) = @_;
3632
my @required_args = qw(DSNParser OptionParser);
3633
foreach my $arg ( @required_args ) {
3634
die "I need a $arg argument" unless $args{$arg};
3636
my ($dp, $o) = @args{@required_args};
3638
my $dsn_defaults = $dp->parse_options($o);
3639
my $prev_dsn = $args{prev_dsn};
3640
my $dsn = $args{dsn};
3642
$args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
3645
$args{dsn_string}, $prev_dsn, $dsn_defaults);
3647
elsif ( $prev_dsn ) {
3648
$dsn = $dp->copy($prev_dsn, $dsn);
3651
my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
3652
|| $dp->as_string($dsn, [qw(F)])
3658
dsn_name => $dsn_name,
3661
NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
3663
ask_pass => $args{ask_pass},
3665
is_cluster_node => undef,
3666
parent => $args{parent},
3669
return bless $self, $class;
3673
my ( $self, %opts ) = @_;
3674
my $dsn = $opts{dsn} || $self->{dsn};
3675
my $dp = $self->{DSNParser};
3677
my $dbh = $self->{dbh};
3678
if ( !$dbh || !$dbh->ping() ) {
3679
if ( $self->{ask_pass} && !$self->{asked_for_pass} ) {
3680
$dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: ");
3681
$self->{asked_for_pass} = 1;
3683
$dbh = $dp->get_dbh(
3684
$dp->get_cxn_params($dsn),
3692
$dbh = $self->set_dbh($dbh);
3694
$self->{dsn} = $dsn;
3695
$self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
3696
|| $dp->as_string($dsn, [qw(F)])
3700
PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
3705
my ($self, $dbh) = @_;
3707
if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
3708
PTDEBUG && _d($dbh, 'Already set dbh');
3712
PTDEBUG && _d($dbh, 'Setting dbh');
3714
$dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
3716
my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/';
3717
PTDEBUG && _d($dbh, $sql);
3718
my ($server_id, $hostname) = $dbh->selectrow_array($sql);
3719
PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id);
3721
$self->{hostname} = $hostname;
3724
if ( $self->{parent} ) {
3725
PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
3726
$dbh->{InactiveDestroy} = 1;
3729
if ( my $set = $self->{set}) {
3733
$self->{dbh} = $dbh;
3734
$self->{dbh_set} = 1;
3738
sub lost_connection {
3739
my ($self, $e) = @_;
3741
return $e =~ m/MySQL server has gone away/
3742
|| $e =~ m/Lost connection to MySQL server/;
3747
return $self->{dbh};
3752
return $self->{dsn};
3757
return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
3758
return $self->{hostname} || $self->{dsn_name} || 'unknown host';
3761
sub remove_duplicate_cxns {
3762
my ($self, %args) = @_;
3763
my @cxns = @{$args{cxns}};
3764
my $seen_ids = $args{seen_ids} || {};
3765
PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns));
3768
for my $cxn ( @cxns ) {
3769
my $dbh = $cxn->dbh();
3770
my $sql = q{SELECT @@server_id};
3771
PTDEBUG && _d($sql);
3772
my ($id) = $dbh->selectrow_array($sql);
3773
PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
3775
if ( ! $seen_ids->{$id}++ ) {
3776
push @trimmed_cxns, $cxn
3779
PTDEBUG && _d("Removing ", $cxn->name,
3780
", ID ", $id, ", because we've already seen it");
3784
return \@trimmed_cxns;
3790
PTDEBUG && _d('Destroying cxn');
3792
if ( $self->{parent} ) {
3793
PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
3795
elsif ( $self->{dbh}
3796
&& blessed($self->{dbh})
3797
&& $self->{dbh}->can("disconnect") )
3799
PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
3801
$self->{dbh}->disconnect();
3808
my ($package, undef, $line) = caller 0;
3809
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3810
map { defined $_ ? $_ : 'undef' }
3812
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3817
# ###########################################################################
3819
# ###########################################################################
3821
# ###########################################################################
3823
# This package is a copy without comments from the original. The original
3824
# with comments and its test file can be found in the Bazaar repository at,
3827
# See https://launchpad.net/percona-toolkit for more information.
3828
# ###########################################################################
3833
use warnings FATAL => 'all';
3834
use English qw(-no_match_vars);
3835
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3838
$Data::Dumper::Indent = 1;
3839
$Data::Dumper::Sortkeys = 1;
3840
$Data::Dumper::Quotekeys = 0;
3843
my ( $class, %args ) = @_;
3844
return bless {}, $class;
3848
my ( $self, @vals ) = @_;
3849
foreach my $val ( @vals ) {
3852
return join('.', map { '`' . $_ . '`' } @vals);
3856
my ( $self, $val, %args ) = @_;
3858
return 'NULL' unless defined $val; # undef = NULL
3859
return "''" if $val eq ''; # blank string = ''
3860
return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data
3861
&& !$args{is_char}; # unless is_char is true
3863
return $val if $args{is_float};
3865
$val =~ s/(['\\])/\\$1/g;
3870
my ( $self, $db_tbl, $default_db ) = @_;
3871
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
3887
my ( $self, $like ) = @_;
3888
return unless $like;
3889
$like =~ s/([%_])/\\$1/g;
3894
my ( $self, $default_db, $db_tbl ) = @_;
3895
return unless $db_tbl;
3896
my ($db, $tbl) = split(/[.]/, $db_tbl);
3901
$db = "`$db`" if $db && $db !~ m/^`/;
3902
$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
3903
return $db ? "$db.$tbl" : $tbl;
3906
sub serialize_list {
3907
my ( $self, @args ) = @_;
3908
PTDEBUG && _d('Serializing', Dumper(\@args));
3909
return unless @args;
3912
foreach my $arg ( @args ) {
3913
if ( defined $arg ) {
3914
$arg =~ s/,/\\,/g; # escape commas
3915
$arg =~ s/\\N/\\\\N/g; # escape literal \N
3923
my $string = join(',', @parts);
3924
PTDEBUG && _d('Serialized: <', $string, '>');
3928
sub deserialize_list {
3929
my ( $self, $string ) = @_;
3930
PTDEBUG && _d('Deserializing <', $string, '>');
3931
die "Cannot deserialize an undefined string" unless defined $string;
3934
foreach my $arg ( split(/(?<!\\),/, $string) ) {
3935
if ( $arg eq '\N' ) {
3940
$arg =~ s/\\\\N/\\N/g;
3946
my $n_empty_strings = $string =~ tr/,//;
3948
PTDEBUG && _d($n_empty_strings, 'empty strings');
3949
map { push @parts, '' } 1..$n_empty_strings;
3951
elsif ( $string =~ m/(?<!\\),$/ ) {
3952
PTDEBUG && _d('Last value is an empty string');
3956
PTDEBUG && _d('Deserialized', Dumper(\@parts));
3961
my ($package, undef, $line) = caller 0;
3962
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3963
map { defined $_ ? $_ : 'undef' }
3965
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3970
# ###########################################################################
3971
# End Quoter package
3972
# ###########################################################################
3974
# ###########################################################################
3975
# VersionParser package
3976
# This package is a copy without comments from the original. The original
3977
# with comments and its test file can be found in the Bazaar repository at,
3978
# lib/VersionParser.pm
3979
# t/lib/VersionParser.t
3980
# See https://launchpad.net/percona-toolkit for more information.
3981
# ###########################################################################
3983
package VersionParser;
3986
use Scalar::Util qw(blessed);
3987
use English qw(-no_match_vars);
3988
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4005
has [qw( minor revision )] => (
4013
default => sub { 'Unknown' },
4016
has innodb_version => (
4019
default => sub { 'NO' },
4024
return $self->_join_version($self->major, $self->minor);
4029
return $self->_join_version($self->major, $self->minor, $self->revision);
4033
my ($self, $target) = @_;
4035
return $self eq $target;
4039
my ($self, @parts) = @_;
4041
return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts;
4043
sub _split_version {
4044
my ($self, $str) = @_;
4045
my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g;
4046
return @version_parts[0..2];
4049
sub normalized_version {
4051
my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major,
4054
PTDEBUG && _d($self->version, 'normalizes to', $result);
4059
my ( $self, $cmd ) = @_;
4060
my $v = $self->normalized_version();
4062
return "/*!$v $cmd */"
4065
my @methods = qw(major minor revision);
4067
my ($left, $right) = @_;
4068
my $right_obj = (blessed($right) && $right->isa(ref($left)))
4070
: ref($left)->new($right);
4073
for my $m ( @methods ) {
4074
last unless defined($left->$m) && defined($right_obj->$m);
4075
$retval = $left->$m <=> $right_obj->$m;
4086
if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) {
4087
PTDEBUG && _d("VersionParser got a dbh, trying to get the version");
4089
local $dbh->{FetchHashKeyName} = 'NAME_lc';
4091
$dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} })
4094
$query = { map { $_->{variable_name} => $_->{value} } @$query };
4095
@args{@methods} = $self->_split_version($query->{version});
4096
$args{flavor} = delete $query->{version_comment}
4097
if $query->{version_comment};
4099
elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) {
4100
@args{@methods} = $self->_split_version($query);
4103
Carp::confess("Couldn't get the version from the dbh while "
4104
. "creating a VersionParser object: $@");
4106
$args{innodb_version} = eval { $self->_innodb_version($dbh) };
4108
elsif ( !ref($_[0]) ) {
4109
@args{@methods} = $self->_split_version($_[0]);
4112
for my $method (@methods) {
4113
delete $args{$method} unless defined $args{$method};
4115
@_ = %args if %args;
4118
return $self->SUPER::BUILDARGS(@_);
4121
sub _innodb_version {
4122
my ( $self, $dbh ) = @_;
4124
my $innodb_version = "NO";
4127
grep { $_->{engine} =~ m/InnoDB/i }
4130
@hash{ map { lc $_ } keys %$_ } = values %$_;
4133
@{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
4135
PTDEBUG && _d("InnoDB support:", $innodb->{support});
4136
if ( $innodb->{support} =~ m/YES|DEFAULT/i ) {
4137
my $vars = $dbh->selectrow_hashref(
4138
"SHOW VARIABLES LIKE 'innodb_version'");
4139
$innodb_version = !$vars ? "BUILTIN"
4140
: ($vars->{Value} || $vars->{value});
4143
$innodb_version = $innodb->{support}; # probably DISABLED or NO
4147
PTDEBUG && _d("InnoDB version:", $innodb_version);
4148
return $innodb_version;
4152
my ($package, undef, $line) = caller 0;
4153
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4154
map { defined $_ ? $_ : 'undef' }
4156
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4162
# ###########################################################################
4163
# End VersionParser package
4164
# ###########################################################################
4166
# ###########################################################################
4168
# This package is a copy without comments from the original. The original
4169
# with comments and its test file can be found in the Bazaar repository at,
4172
# See https://launchpad.net/percona-toolkit for more information.
4173
# ###########################################################################
4178
use warnings FATAL => 'all';
4179
use English qw(-no_match_vars);
4181
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4183
use POSIX qw(setsid);
4184
use Fcntl qw(:DEFAULT);
4187
my ($class, %args) = @_;
4189
log_file => $args{log_file},
4190
pid_file => $args{pid_file},
4191
daemonize => $args{daemonize},
4192
force_log_file => $args{force_log_file},
4193
parent_exit => $args{parent_exit},
4194
pid_file_owner => 0,
4196
return bless $self, $class;
4202
my $daemonize = $self->{daemonize};
4203
my $pid_file = $self->{pid_file};
4204
my $log_file = $self->{log_file};
4205
my $force_log_file = $self->{force_log_file};
4206
my $parent_exit = $self->{parent_exit};
4208
PTDEBUG && _d('Starting daemon');
4212
$self->_make_pid_file(
4213
pid => $PID, # parent's pid
4214
pid_file => $pid_file,
4217
die "$EVAL_ERROR\n" if $EVAL_ERROR;
4218
if ( !$daemonize ) {
4219
$self->{pid_file_owner} = $PID; # parent's pid
4224
defined (my $child_pid = fork()) or die "Cannot fork: $OS_ERROR";
4226
PTDEBUG && _d('Forked child', $child_pid);
4227
$parent_exit->($child_pid) if $parent_exit;
4231
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
4232
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
4235
$self->_update_pid_file(
4236
pid => $PID, # child's pid
4237
pid_file => $pid_file,
4239
$self->{pid_file_owner} = $PID;
4243
if ( $daemonize || $force_log_file ) {
4244
PTDEBUG && _d('Redirecting STDIN to /dev/null');
4246
open STDIN, '/dev/null'
4247
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
4249
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $log_file);
4251
open STDOUT, '>>', $log_file
4252
or die "Cannot open log file $log_file: $OS_ERROR";
4255
open STDERR, ">&STDOUT"
4256
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
4260
PTDEBUG && _d('No log file and STDOUT is a terminal;',
4261
'redirecting to /dev/null');
4263
open STDOUT, '>', '/dev/null'
4264
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
4267
PTDEBUG && _d('No log file and STDERR is a terminal;',
4268
'redirecting to /dev/null');
4270
open STDERR, '>', '/dev/null'
4271
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
4275
$OUTPUT_AUTOFLUSH = 1;
4278
PTDEBUG && _d('Daemon running');
4282
sub _make_pid_file {
4283
my ($self, %args) = @_;
4284
my @required_args = qw(pid pid_file);
4285
foreach my $arg ( @required_args ) {
4286
die "I need a $arg argument" unless $args{$arg};
4288
my $pid = $args{pid};
4289
my $pid_file = $args{pid_file};
4292
sysopen(PID_FH, $pid_file, O_RDWR|O_CREAT|O_EXCL) or die $OS_ERROR;
4293
print PID_FH $PID, "\n";
4296
if ( my $e = $EVAL_ERROR ) {
4297
if ( $e =~ m/file exists/i ) {
4298
my $old_pid = $self->_check_pid_file(
4299
pid_file => $pid_file,
4303
warn "Overwriting PID file $pid_file because PID $old_pid "
4304
. "is not running.\n";
4306
$self->_update_pid_file(
4308
pid_file => $pid_file
4312
die "Error creating PID file $pid_file: $e\n";
4319
sub _check_pid_file {
4320
my ($self, %args) = @_;
4321
my @required_args = qw(pid_file pid);
4322
foreach my $arg ( @required_args ) {
4323
die "I need a $arg argument" unless $args{$arg};
4325
my $pid_file = $args{pid_file};
4326
my $pid = $args{pid};
4328
PTDEBUG && _d('Checking if PID in', $pid_file, 'is running');
4330
if ( ! -f $pid_file ) {
4331
PTDEBUG && _d('PID file', $pid_file, 'does not exist');
4335
open my $fh, '<', $pid_file
4336
or die "Error opening $pid_file: $OS_ERROR";
4337
my $existing_pid = do { local $/; <$fh> };
4338
chomp($existing_pid) if $existing_pid;
4340
or die "Error closing $pid_file: $OS_ERROR";
4342
if ( $existing_pid ) {
4343
if ( $existing_pid == $pid ) {
4344
warn "The current PID $pid already holds the PID file $pid_file\n";
4348
PTDEBUG && _d('Checking if PID', $existing_pid, 'is running');
4349
my $pid_is_alive = kill 0, $existing_pid;
4350
if ( $pid_is_alive ) {
4351
die "PID file $pid_file exists and PID $existing_pid is running\n";
4356
die "PID file $pid_file exists but it is empty. Remove the file "
4357
. "if the process is no longer running.\n";
4360
return $existing_pid;
4363
sub _update_pid_file {
4364
my ($self, %args) = @_;
4365
my @required_args = qw(pid pid_file);
4366
foreach my $arg ( @required_args ) {
4367
die "I need a $arg argument" unless $args{$arg};
4369
my $pid = $args{pid};
4370
my $pid_file = $args{pid_file};
4372
open my $fh, '>', $pid_file
4373
or die "Cannot open $pid_file: $OS_ERROR";
4374
print { $fh } $pid, "\n"
4375
or die "Cannot print to $pid_file: $OS_ERROR";
4377
or warn "Cannot close $pid_file: $OS_ERROR";
4382
sub remove_pid_file {
4383
my ($self, $pid_file) = @_;
4384
$pid_file ||= $self->{pid_file};
4385
if ( $pid_file && -f $pid_file ) {
4386
unlink $self->{pid_file}
4387
or warn "Cannot remove PID file $pid_file: $OS_ERROR";
4388
PTDEBUG && _d('Removed PID file');
4391
PTDEBUG && _d('No PID to remove');
4399
if ( $self->{pid_file_owner} == $PID ) {
4400
$self->remove_pid_file();
4407
my ($package, undef, $line) = caller 0;
4408
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4409
map { defined $_ ? $_ : 'undef' }
4411
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4416
# ###########################################################################
4417
# End Daemon package
4418
# ###########################################################################
4420
# ###########################################################################
4421
# Transformers package
4422
# This package is a copy without comments from the original. The original
4423
# with comments and its test file can be found in the Bazaar repository at,
4424
# lib/Transformers.pm
4425
# t/lib/Transformers.t
4426
# See https://launchpad.net/percona-toolkit for more information.
4427
# ###########################################################################
4429
package Transformers;
4432
use warnings FATAL => 'all';
4433
use English qw(-no_match_vars);
4434
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4436
use Time::Local qw(timegm timelocal);
4437
use Digest::MD5 qw(md5_hex);
4442
our @ISA = qw(Exporter);
4443
our %EXPORT_TAGS = ();
4445
our @EXPORT_OK = qw(
4461
our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
4462
our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
4463
our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
4466
my ( $t, %args ) = @_;
4467
my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
4468
my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
4473
$t = sprintf('%.17f', $t) if $t =~ /e/;
4475
$t =~ s/\.(\d{1,6})\d*/\.$1/;
4477
if ($t > 0 && $t <= 0.000999) {
4478
$f = ($t * 1000000) . 'us';
4480
elsif ($t >= 0.001000 && $t <= 0.999999) {
4481
$f = sprintf("%.${p_ms}f", $t * 1000);
4482
$f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
4485
$f = sprintf("%.${p_s}f", $t);
4486
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
4489
$f = 0; # $t should = 0 at this point
4496
my ( $is, $of, %args ) = @_;
4497
my $p = $args{p} || 0; # float precision
4498
my $fmt = $p ? "%.${p}f" : "%d";
4499
return sprintf $fmt, ($is * 100) / ($of ||= 1);
4503
my ( $secs, $fmt ) = @_;
4505
return '00:00' unless $secs;
4507
$fmt ||= $secs >= 86_400 ? 'd'
4508
: $secs >= 3_600 ? 'h'
4512
$fmt eq 'd' ? sprintf(
4513
"%d+%02d:%02d:%02d",
4514
int($secs / 86_400),
4515
int(($secs % 86_400) / 3_600),
4516
int(($secs % 3_600) / 60),
4518
: $fmt eq 'h' ? sprintf(
4520
int(($secs % 86_400) / 3_600),
4521
int(($secs % 3_600) / 60),
4525
int(($secs % 3_600) / 60),
4530
my ( $val, $default_suffix ) = @_;
4531
die "I need a val argument" unless defined $val;
4533
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
4534
$suffix = $suffix || $default_suffix || 's';
4535
if ( $suffix =~ m/[smhd]/ ) {
4536
$t = $suffix eq 's' ? $num * 1 # Seconds
4537
: $suffix eq 'm' ? $num * 60 # Minutes
4538
: $suffix eq 'h' ? $num * 3600 # Hours
4539
: $num * 86400; # Days
4541
$t *= -1 if $prefix && $prefix eq '-';
4544
die "Invalid suffix for $val: $suffix";
4550
my ( $num, %args ) = @_;
4551
my $p = defined $args{p} ? $args{p} : 2; # float precision
4552
my $d = defined $args{d} ? $args{d} : 1_024; # divisor
4554
my @units = ('', qw(k M G T P E Z Y));
4555
while ( $num >= $d && $n < @units - 1 ) {
4567
my ( $time, $gmt ) = @_;
4568
my ( $sec, $min, $hour, $mday, $mon, $year )
4569
= $gmt ? gmtime($time) : localtime($time);
4572
my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
4573
$year, $mon, $mday, $hour, $min, $sec);
4574
if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
4575
$us = sprintf("%.6f", $us);
4582
sub parse_timestamp {
4584
if ( my($y, $m, $d, $h, $i, $s, $f)
4585
= $val =~ m/^$mysql_ts$/ )
4587
return sprintf "%d-%02d-%02d %02d:%02d:"
4588
. (defined $f ? '%09.6f' : '%02d'),
4589
$y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
4591
elsif ( $val =~ m/^$proper_ts$/ ) {
4597
sub unix_timestamp {
4598
my ( $val, $gmt ) = @_;
4599
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
4601
? timegm($s, $i, $h, $d, $m - 1, $y)
4602
: timelocal($s, $i, $h, $d, $m - 1, $y);
4603
if ( defined $us ) {
4604
$us = sprintf('%.6f', $us);
4612
sub any_unix_timestamp {
4613
my ( $val, $callback ) = @_;
4615
if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
4616
$n = $suffix eq 's' ? $n # Seconds
4617
: $suffix eq 'm' ? $n * 60 # Minutes
4618
: $suffix eq 'h' ? $n * 3600 # Hours
4619
: $suffix eq 'd' ? $n * 86400 # Days
4620
: $n; # default: Seconds
4621
PTDEBUG && _d('ts is now - N[shmd]:', $n);
4624
elsif ( $val =~ m/^\d{9,}/ ) {
4625
PTDEBUG && _d('ts is already a unix timestamp');
4628
elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
4629
PTDEBUG && _d('ts is MySQL slow log timestamp');
4630
$val .= ' 00:00:00' unless $hms;
4631
return unix_timestamp(parse_timestamp($val));
4633
elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
4634
PTDEBUG && _d('ts is properly formatted timestamp');
4635
$val .= ' 00:00:00' unless $hms;
4636
return unix_timestamp($val);
4639
PTDEBUG && _d('ts is MySQL expression');
4640
return $callback->($val) if $callback && ref $callback eq 'CODE';
4643
PTDEBUG && _d('Unknown ts type:', $val);
4649
my $checksum = uc substr(md5_hex($val), -16);
4650
PTDEBUG && _d($checksum, 'checksum for', $val);
4655
my ( $string ) = @_;
4656
return unless $string;
4657
my $poly = 0xEDB88320;
4658
my $crc = 0xFFFFFFFF;
4659
foreach my $char ( split(//, $string) ) {
4660
my $comp = ($crc ^ ord($char)) & 0xFF;
4662
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
4664
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
4666
return $crc ^ 0xFFFFFFFF;
4669
my $got_json = eval { require JSON };
4671
return JSON::encode_json(@_) if $got_json;
4673
return (object_to_json($data) || '');
4677
sub object_to_json {
4679
my $type = ref($obj);
4681
if($type eq 'HASH'){
4682
return hash_to_json($obj);
4684
elsif($type eq 'ARRAY'){
4685
return array_to_json($obj);
4688
return value_to_json($obj);
4695
for my $k ( sort { $a cmp $b } keys %$obj ) {
4696
push @res, string_to_json( $k )
4698
. ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) );
4700
return '{' . ( @res ? join( ",", @res ) : '' ) . '}';
4708
push @res, object_to_json($v) || value_to_json($v);
4711
return '[' . ( @res ? join( ",", @res ) : '' ) . ']';
4717
return 'null' if(!defined $value);
4719
my $b_obj = B::svref_2object(\$value); # for round trip problem
4720
my $flags = $b_obj->FLAGS;
4721
return $value # as is
4722
if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
4724
my $type = ref($value);
4727
return string_to_json($value);
4746
sub string_to_json {
4749
$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
4750
$arg =~ s/\//\\\//g;
4751
$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
4753
utf8::upgrade($arg);
4756
return '"' . $arg . '"';
4760
my ($package, undef, $line) = caller 0;
4761
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4762
map { defined $_ ? $_ : 'undef' }
4764
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4769
# ###########################################################################
4770
# End Transformers package
4771
# ###########################################################################
4773
# ###########################################################################
4774
# Safeguards package
4775
# This package is a copy without comments from the original. The original
4776
# with comments and its test file can be found in the Bazaar repository at,
4778
# t/lib/Safeguards.t
4779
# See https://launchpad.net/percona-toolkit for more information.
4780
# ###########################################################################
4785
use warnings FATAL => 'all';
4786
use English qw(-no_match_vars);
4788
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4791
my ($class, %args) = @_;
4793
disk_bytes_free => $args{disk_bytes_free} || 104857600, # 100 MiB
4794
disk_pct_free => $args{disk_pct_free} || 5,
4796
return bless $self, $class;
4799
sub get_disk_space {
4800
my ($self, %args) = @_;
4801
my $filesystem = $args{filesystem} || $ENV{PWD};
4803
my $disk_space = `df -P -k "$filesystem"`;
4804
chop($disk_space) if $disk_space;
4805
PTDEBUG && _d('Disk space on', $filesystem, $disk_space);
4810
sub check_disk_space() {
4811
my ($self, %args) = @_;
4812
my $disk_space = $args{disk_space};
4813
PTDEBUG && _d("Checking disk space:\n", $disk_space);
4815
my ($partition) = $disk_space =~ m/^\s*(\/.+)/m;
4816
PTDEBUG && _d('Partition:', $partition);
4817
die "Failed to parse partition from disk space:\n$disk_space"
4820
my (undef, undef, $bytes_used, $bytes_free, $pct_used, undef)
4821
= $partition =~ m/(\S+)/g;
4822
PTDEBUG && _d('Bytes used:', $bytes_used, 'free:', $bytes_free,
4823
'Percentage used:', $pct_used);
4825
$bytes_used = ($bytes_used || 0) * 1024;
4826
$bytes_free = ($bytes_free || 0) * 1024;
4829
my $pct_free = 100 - ($pct_used || 0);
4831
return $bytes_free >= $self->{disk_bytes_free}
4832
&& $pct_free >= $self->{disk_pct_free};
4836
my ($package, undef, $line) = caller 0;
4837
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4838
map { defined $_ ? $_ : 'undef' }
4840
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4845
# ###########################################################################
4846
# End Safeguards package
4847
# ###########################################################################
4849
# ###########################################################################
4850
# Percona::Agent::Logger package
4851
# This package is a copy without comments from the original. The original
4852
# with comments and its test file can be found in the Bazaar repository at,
4853
# lib/Percona/Agent/Logger.pm
4854
# t/lib/Percona/Agent/Logger.t
4855
# See https://launchpad.net/percona-toolkit for more information.
4856
# ###########################################################################
4858
package Percona::Agent::Logger;
4861
use warnings FATAL => 'all';
4862
use English qw(-no_match_vars);
4864
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4866
use POSIX qw(SIGALRM);
4870
use Percona::WebAPI::Resource::LogEntry;
4872
Transformers->import(qw(ts));
4874
has 'exit_status' => (
4888
isa => 'Maybe[Str]',
4890
default => sub { return; },
4895
isa => 'Maybe[Int]',
4897
default => sub { return; },
4900
has 'online_logging' => (
4904
default => sub { return 1 },
4907
has 'online_logging_enabled' => (
4911
default => sub { return 0 },
4918
default => sub { return 0 },
4925
default => sub { return []; },
4928
has '_pipe_write' => (
4930
isa => 'Maybe[FileHandle]',
4939
POSIX::SigAction->new(sub { die 'read timeout'; }),
4940
) or die "Error setting SIGALRM handler: $OS_ERROR";
4946
while(defined(my $line = <STDIN>)) {
4951
if ( $EVAL_ERROR ) {
4952
PTDEBUG && _d('Read error:', $EVAL_ERROR);
4953
die $EVAL_ERROR unless $EVAL_ERROR =~ m/read timeout/;
4956
return unless scalar @lines || $timeout;
4960
sub start_online_logging {
4961
my ($self, %args) = @_;
4962
my $client = $args{client};
4963
my $log_link = $args{log_link};
4964
my $read_timeout = $args{read_timeout} || 3;
4966
return unless $self->online_logging;
4968
my $pid = open(my $pipe_write, "|-");
4972
$OUTPUT_AUTOFLUSH = 1;
4973
$self->_pipe_write($pipe_write);
4974
$self->online_logging_enabled(1);
4982
my $lines = read_stdin($read_timeout);
4983
last QUEUE unless $lines;
4985
while ( defined(my $line = shift @$lines) ) {
4986
my ($ts, $level, $n_lines, $msg) = $line =~ m/^([^,]+),([^,]+),([^,]+),(.+)/s;
4987
if ( !$ts || !$level || !$n_lines || !$msg ) {
4991
if ( $n_lines > 1 ) {
4992
$n_lines--; # first line
4993
for ( 1..$n_lines ) {
4994
$msg .= shift @$lines;
4998
push @log_entries, Percona::WebAPI::Resource::LogEntry->new(
5001
log_level => $level,
5003
($self->service ? (service => $self->service) : ()),
5004
($self->data_ts ? (data_ts => $self->data_ts) : ()),
5008
if ( scalar @log_entries ) {
5012
resources => \@log_entries,
5015
if ( my $e = $EVAL_ERROR ) {
5016
if ( ++$n_errors <= 10 ) {
5017
warn "Error sending log entry to API: $e";
5018
if ( $n_errors == 10 ) {
5019
my $ts = ts(time, 1); # 1=UTC
5020
warn "$ts WARNING $n_errors consecutive errors, no more "
5021
. "error messages will be printed until log entries "
5022
. "are sent successfully again.\n";
5030
} # have log entries
5032
my $n_log_entries = scalar @log_entries;
5033
if ( $n_log_entries > 1_000 ) {
5034
warn "$n_log_entries log entries in send buffer, "
5035
. "removing first 100 to avoid excessive usage.\n";
5036
@log_entries = @log_entries[100..($n_log_entries-1)];
5040
if ( scalar @log_entries ) {
5041
my $ts = ts(time, 1); # 1=UTC
5042
warn "$ts WARNING Failed to send these log entries "
5043
. "(timestamps are UTC):\n";
5044
foreach my $log ( @log_entries ) {
5045
warn sprintf("%s %s %s\n",
5047
level_name($log->log_level),
5061
die "No log level name given" unless $name;
5062
my $number = $name eq 'DEBUG' ? 1
5063
: $name eq 'INFO' ? 2
5064
: $name eq 'WARNING' ? 3
5065
: $name eq 'ERROR' ? 4
5066
: $name eq 'FATAL' ? 5
5067
: die "Invalid log level name: $name";
5072
die "No log level name given" unless $number;
5073
my $name = $number == 1 ? 'DEBUG'
5074
: $number == 2 ? 'INFO'
5075
: $number == 3 ? 'WARNING'
5076
: $number == 4 ? 'ERROR'
5077
: $number == 5 ? 'FATAL'
5078
: die "Invalid log level number: $number";
5083
return if $self->online_logging;
5084
return $self->_log(0, 'DEBUG', @_);
5089
return $self->_log(1, 'INFO', @_);
5094
$self->_set_exit_status();
5095
return $self->_log(1, 'WARNING', @_);
5100
$self->_set_exit_status();
5101
return $self->_log(1, 'ERROR', @_);
5106
$self->_set_exit_status();
5107
$self->_log(1, 'FATAL', @_);
5108
exit $self->exit_status;
5111
sub _set_exit_status {
5113
my $exit_status = $self->exit_status; # get ref
5114
$$exit_status |= 1; # deref to set
5115
$self->exit_status($exit_status); # save back ref
5120
my ($self, $online, $level, $msg) = @_;
5122
my $ts = ts(time, 1); # 1=UTC
5123
my $level_number = level_number($level);
5125
return if $self->quiet && $level_number < $self->quiet;
5129
$n_lines++ while $msg =~ m/\n/g;
5131
if ( $online && $self->online_logging_enabled ) {
5132
while ( defined(my $log_entry = shift @{$self->_buffer}) ) {
5133
$self->_queue_log_entry(@$log_entry);
5135
$self->_queue_log_entry($ts, $level_number, $n_lines, $msg);
5138
if ( $online && $self->online_logging ) {
5139
push @{$self->_buffer}, [$ts, $level_number, $n_lines, $msg];
5142
if ( $level_number >= 3 ) { # warning
5143
print STDERR "$ts $level $msg\n";
5146
print STDOUT "$ts $level $msg\n";
5153
sub _queue_log_entry {
5154
my ($self, $ts, $log_level, $n_lines, $msg) = @_;
5155
print "$ts,$log_level,$n_lines,$msg\n";
5160
my ($package, undef, $line) = caller 0;
5161
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
5162
map { defined $_ ? $_ : 'undef' }
5164
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
5170
# ###########################################################################
5171
# End Percona::Agent::Logger package
5172
# ###########################################################################
5174
# ###########################################################################
5175
# Percona::Agent::Exception::*
5176
# ###########################################################################
5179
package Percona::Agent::Exception::PIDNotFound;
5182
use overload '""' => \&as_string;
5186
isa => 'Maybe[Str]',
5192
return sprintf "PID file %s does not exist and no matching "
5193
. "process was found in ps", $self->pid_file;
5201
package Percona::Agent::Exception::NoPID;
5204
use overload '""' => \&as_string;
5208
isa => 'Maybe[Str]',
5212
has 'pid_file_is_empty' => (
5220
if ( $self->pid_file_is_empty ) {
5221
return sprintf "PID file %s is empty", $self->pid_file;
5224
return sprintf "PID file %s does not exist and parsing ps output "
5225
. "failed", $self->pid_file;
5234
package Percona::Agent::Exception::PIDNotRunning;
5237
use overload '""' => \&as_string;
5247
return sprintf "PID is not running", $self->pid;
5255
$INC{'Percona/Agent/Exception/PIDNotFound.pm'} = __FILE__;
5256
$INC{'Percona/Agent/Exception/NoPID.pm'} = __FILE__;
5257
$INC{'Percona/Agent/Exception/PIDNotRunning.pm'} = __FILE__;
5260
# ###########################################################################
5261
# This is a combination of modules and programs in one -- a runnable module.
5262
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
5263
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
5265
# Check at the end of this package for the call to main() which actually runs
5267
# ###########################################################################
5271
use warnings FATAL => 'all';
5272
use English qw(-no_match_vars);
5273
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
5275
use Scalar::Util qw(blessed);
5276
use POSIX qw(signal_h);
5277
use Time::HiRes qw(sleep time);
5278
use File::Temp qw(tempfile);
5283
use Percona::Toolkit;
5284
use Percona::WebAPI::Client;
5285
use Percona::WebAPI::Exception::Request;
5286
use Percona::WebAPI::Exception::Resource;
5287
use Percona::WebAPI::Resource::Agent;
5288
use Percona::WebAPI::Resource::Config;
5289
use Percona::WebAPI::Resource::Service;
5290
use Percona::WebAPI::Representation;
5291
use Percona::Agent::Exception::PIDNotFound;
5292
use Percona::Agent::Exception::NoPID;
5293
use Percona::Agent::Exception::PIDNotRunning;
5295
Percona::Toolkit->import(qw(_d Dumper have_required_args));
5296
Percona::WebAPI::Representation->import(qw(as_json as_config));
5297
Transformers->import(qw(ts));
5299
use sigtrap 'handler', \&sig_int, 'normal-signals';
5300
use sigtrap 'handler', \&reload_signal, 'USR1';
5303
my $exit_status = 0;
5305
my $exit_on_signals = 0;
5308
use constant MAX_DATA_FILE_SIZE => 15_728_640; # 15M
5312
=> [qw(DBI libdbi-perl perl-DBI)],
5314
=> [qw(DBD::mysql libdbd-mysql-perl perl-DBD-MySQL)],
5316
=> [qw(JSON libjson-perl perl-JSON)],
5318
=> [qw(LWP libwww-perl perl-libwww-perl)],
5320
=> [qw(IO::Socket::SSL libio-socket-ssl-perl perl-IO-Socket-SSL)],
5323
# Will check this later.
5331
# Reset global vars else tests will fail in strange ways.
5335
$exit_on_signals = 0;
5337
# ########################################################################
5338
# Get configuration information.
5339
# ########################################################################
5340
my $o = new OptionParser();
5344
my $dp = $o->DSNParser();
5345
$dp->prop('set-vars', $o->set_vars());
5347
# We're _not_ running as root, so unless --pid and --log have
5348
# already been configured, the defaults won't work. In this
5349
# case, use tmp values until a new config is received.
5351
$o->set('pid', '/tmp/pt-agent.pid') unless $o->got('pid');
5352
$o->set('log', '/tmp/pt-agent.log') unless $o->got('log');
5353
$o->set('lib', '/tmp/pt-agent' ) unless $o->got('lib');
5356
if ( !$o->get('help') ) {
5359
$o->usage_or_errors();
5361
if ( $o->get('interactive')
5362
|| $o->get('install')
5363
|| $o->get('uninstall') ) {
5364
$OUTPUT_AUTOFLUSH = 1
5367
# ########################################################################
5368
# Fail-safe: if the agent somehow runs away, i.e. starts to fork-bomb,
5370
# ########################################################################
5371
my $lib_dir = $o->get('lib');
5372
if ( too_many_agents(lib_dir => $lib_dir) ) {
5375
lib_dir => $lib_dir,
5377
die "Too many agents are running. Remove the PID files in "
5378
. "$lib_dir/pids/ if the agents are no longer running. Else, "
5379
. "check the log files in $lib_dir/logs/ and online to see "
5380
. "if the agent is stuck in a loop. Please contact Percona "
5381
. "if you need urgent help.\n";
5384
# ########################################################################
5385
# Connect to MysSQL later, maybe.
5386
# ########################################################################
5391
ask_pass => $o->get('ask-pass'),
5394
# ########################################################################
5395
# Make a logger, not online yet.
5396
# ########################################################################
5397
$logger = Percona::Agent::Logger->new(
5398
exit_status => \$exit_status,
5400
online_logging => $o->get('log-api') ? 1 : 0,
5403
# ########################################################################
5404
# --(un)install and exit.
5405
# ########################################################################
5406
if ( $o->get('install') ) {
5407
$exit_on_signals = 1;
5411
interactive => $o->get('interactive'),
5412
flags => $o->get('install-options'),
5414
return $exit_status;
5416
elsif ( $o->get('uninstall') ) {
5417
$exit_on_signals = 1;
5422
return $exit_status;
5425
# ########################################################################
5426
# Nothing works without required Perl modules.
5427
# ########################################################################
5428
if ( missing_perl_module_deps() ) {
5429
$logger->fatal("Missing required Perl modules");
5432
# Check that LWP is new enough
5433
# https://bugs.launchpad.net/percona-toolkit/+bug/1226721
5434
if ( $LWP::VERSION < '5.813' ) {
5435
die "Perl module LWP v5.813 or newer is required; v$LWP::VERSION is installed. Please upgrade LWP on this server.\n"
5438
# ########################################################################
5439
# Nothing works without an API key.
5440
# ########################################################################
5441
my $api_key = $o->get('api-key');
5443
$logger->fatal("No API key was found or specified. pt-agent requires a "
5444
. "Percona Cloud Tools API key. Put your API key "
5445
. "in a --config file or specify it with --api-key.");
5448
# ########################################################################
5449
# --status, --stop, and --reset
5450
# ########################################################################
5451
if ( $o->get('status') ) {
5453
api_key => $o->get('api-key'),
5454
pid_file => $o->get('pid'),
5455
lib_dir => $o->get('lib'),
5457
return $exit_status;
5459
elsif ( $o->get('stop') ) {
5461
pid_file => $o->get('pid'),
5462
lib_dir => $o->get('lib'),
5464
$logger->info("Done stopping pt-agent, exit $exit_status");
5465
return $exit_status;
5467
elsif ( my $n = $o->get('reset') ) {
5468
$exit_on_signals = 1;
5470
my $api_key = $o->get('api-key');
5471
if ( !$api_key && $n < 2 ) {
5472
my $config_file = get_config_file();
5473
if ( -f $config_file ) {
5474
die "Cannot reset pt-agent because an API key is not set in "
5475
. "$config_file and --api-key was not specified. Specify "
5476
. "--api-key to force the reset. Else specify --reset "
5477
. "twice to do a hard reset, after which you will need to "
5478
. "re-install pt-agent.\n";
5481
die "Cannot reset pt-agent because an API key is not set in "
5482
. "$config_file. Add 'api-key=<API key>' to $config_file "
5483
. "or specify it with --api-key. Else specify --reset "
5484
. "twice to do a hard reset, after which you will need to "
5485
. "re-install pt-agent.\n";
5489
pid_file => $o->get('pid'), # for stop_agent()
5490
lib_dir => $o->get('lib'),
5491
spool_dir => $o->get('spool'),
5492
log_file => $o->get('log'),
5493
api_key => $api_key, # optional
5495
if ( $exit_status != 0 ) {
5496
$logger->error("Failed to completely reset pt-agent. "
5497
. "Check the warnings and errors and above and try again.");
5500
$logger->info("pt-agent has been completely reset.");
5502
return $exit_status;
5504
elsif ( $o->get('reload') ) {
5506
pid_file => $o->get('pid'),
5508
return $exit_status;
5511
# ########################################################################
5513
# ########################################################################
5514
if ( $o->get('ping') ) {
5515
my ($client, $entry_links, $logger_client) = get_api_client(
5516
api_key => $api_key,
5518
interval => sub { return },
5520
if ( !$client || !$entry_links ) {
5521
die "Failed to initialize the API client. The API may be down. Please try again.\n";
5523
my $api_ok = ping_api(
5527
print $client->{entry_link} . " is up.\n"
5530
print $client->{entry_link} . " is down or not reachable.\n";
5535
# ########################################################################
5536
# --run-service and exit.
5537
# ########################################################################
5538
if ( my $service = $o->get('run-service') ) {
5541
agent_api => $o->get('agent-api'),
5542
api_key => $api_key,
5543
service => $service,
5544
lib_dir => $o->get('lib'),
5545
spool_dir => $o->get('spool'),
5549
if ( $EVAL_ERROR ) {
5550
$logger->fatal("--run-service $service error: $EVAL_ERROR");
5552
return $exit_status;
5555
# ########################################################################
5556
# --send-data and exit.
5557
# ########################################################################
5558
if ( my $service = $o->get('send-data') ) {
5561
api_key => $api_key,
5562
service => $service,
5563
lib_dir => $o->get('lib'),
5564
spool_dir => $o->get('spool'),
5565
interactive => $o->get('interactive'),
5568
if ( $EVAL_ERROR ) {
5569
$logger->fatal("--send-data $service error: $EVAL_ERROR");
5571
return $exit_status;
5574
# ########################################################################
5575
# This is the main pt-agent daemon, a long-running and resilient
5576
# process. Only internal errors should cause it to stop. Else,
5577
# external errors, like Percona web API not responding, should be
5579
# ########################################################################
5581
# Check the config file. This should probably never fail because
5582
# the config file is $HOME/.pt-agent.conf, so the user should
5583
# be able to write to their home dir. --run-service and --send-data
5584
# don't need to do this because if there's no valid config, they should
5585
# fail; they'll probably die due to --lib missing, which they verify
5587
my $config_file = get_config_file();
5588
if ( -f $config_file && !-w $config_file ) {
5589
$logger->fatal("$config_file exists but is not writable")
5592
# Start, i.e. init/create/update, the agent. This forks and daemonizes,
5593
# so we're the child/daemon process when it returns. To remember how
5594
# this differs from run_agent(): first you start a car, then you put it
5595
# in drive to "run" (drive) it.
5596
my $running = start_agent(
5597
api_key => $api_key,
5599
lib_dir => $o->get('lib'),
5600
daemonize => $o->get('daemonize'),
5601
pid_file => $o->get('pid'),
5602
log_file => $o->get('log'),
5603
# Use default tries and interval: 1440 * 60 = 1 day
5606
# Wait time between checking for new config and services.
5607
# Use the tool's built-in default until a config is gotten,
5608
# then config->{check-interval} will be pass in.
5609
my $check_interval = $o->get('check-interval');
5610
my $interval = sub {
5611
my ($t, $quiet) = @_;
5612
return unless $oktorun;
5613
$t ||= $check_interval;
5614
$logger->debug("Sleeping $t seconds") unless $quiet;
5618
my $safeguards = Safeguards->new(
5619
disk_bytes_free => $o->get('disk-bytes-free'),
5620
disk_pct_free => $o->get('disk-pct-free'),
5623
# Run the agent's main loop which doesn't return until the service
5624
# is stopped, killed, or has an internal bug.
5627
agent => $running->{agent},
5628
client => $running->{client},
5629
daemon => $running->{daemon},
5630
interval => $interval,
5631
safeguards => $safeguards,
5633
lib_dir => $o->get('lib'),
5636
if ( $EVAL_ERROR ) {
5637
$logger->fatal("Error running agent: $EVAL_ERROR");
5640
$logger->info("pt-agent exit $exit_status, oktorun $oktorun");
5642
return $exit_status;
5645
# ############################################################################
5647
# ############################################################################
5649
# ################################################## #
5650
# Percona Web API subs for agent and spool processes #
5651
# ################################################## #
5653
# Create and connect a Percona Web API client.
5654
sub get_api_client {
5657
have_required_args(\%args, qw(
5661
my $api_key = $args{api_key};
5662
my $interval = $args{interval};
5665
my $tries = $args{tries};
5666
my $_oktorun = $args{oktorun} || sub { return $oktorun };
5667
my $entry_link = $args{entry_link} || $ENV{PCT_ENTRY_LINK};
5668
my $quiet = $args{quiet};
5670
my $client = Percona::WebAPI::Client->new(
5671
api_key => $api_key,
5672
($entry_link ? (entry_link => $entry_link) : ()),
5676
while ( $_oktorun->() && (!defined $tries || $tries--) ) {
5677
if ( !$state->{connecting_to_api}++ ) {
5678
$logger->debug("Connecting to Percona Web API") # once
5681
$entry_links = $client->get(link => $client->entry_link);
5683
if ( my $e = $EVAL_ERROR ) {
5684
my $code = $client->response->code;
5685
if ( $code && $code == 503 ) {
5686
$logger->info("API is down for maintenance (503)");
5689
$logger->info("API error: $e");
5694
|| (ref($entry_links) || '') ne 'HASH'
5695
|| !scalar keys %$entry_links
5697
$logger->info('API returned invalid entry links: '
5698
. Dumper($entry_links));
5700
elsif ( !$entry_links->{agents} ) {
5701
$logger->info('API did not return agents link: '
5702
. Dumper($entry_links));
5705
$logger->debug("Connected");
5706
delete $state->{connecting_to_api};
5709
if (!defined $tries || $tries > 0) {
5710
$interval->(); # failure, try again
5714
# Create another client for Percona::Agent::Logger. If the primary
5715
# client was created, then the API key and entry link worked, so
5716
# just duplicate them for the new logger client. We don't need to
5717
# connect the logger client because clients are stateless so knowing
5718
# the primary client connected ensures that the logger client can/will
5719
# connect to with the same API and entry link.
5721
if ( $client && $entry_links ) {
5722
$logger_client = Percona::WebAPI::Client->new(
5723
api_key => $api_key,
5724
($entry_link ? (entry_link => $entry_link) : ()),
5728
return $client, $entry_links, $logger_client;
5731
sub load_local_agent {
5734
have_required_args(\%args, qw(
5737
my $lib_dir = $args{lib_dir};
5740
my $agent_uuid = $args{agent_uuid};
5741
my $quiet = $args{quiet};
5744
my $agent_file = $lib_dir . "/agent";
5745
if ( -f $agent_file ) {
5746
$logger->debug("Reading saved Agent from $agent_file") unless $quiet;
5747
my $agent_hashref = JSON::decode_json(slurp($agent_file));
5748
$agent = Percona::WebAPI::Resource::Agent->new(%$agent_hashref);
5749
if ( !$agent->uuid ) {
5750
$logger->fatal("No UUID for Agent in $agent_file.");
5754
$logger->debug("No local agent") unless $quiet;
5760
# Initialize the agent, i.e. create and return an Agent resource.
5761
# If there's an agent_id, then its updated (PUT), else a new agent
5762
# is created (POST). Doesn't return until successful.
5766
have_required_args(\%args, qw(
5774
my $agent = $args{agent};
5775
my $action = $args{action};
5776
my $link = $args{link};
5777
my $client = $args{client};
5778
my $tries = $args{tries};
5779
my $interval = $args{interval};
5782
my $_oktorun = $args{oktorun} || sub { return $oktorun };
5783
my $actions = $args{actions};
5784
my $quiet = $args{quiet};
5786
# Update these attribs every time the agent is initialized.
5787
# Other optional attribs, like versions, are left to the caller.
5788
chomp(my $who = `whoami 2>/dev/null`);
5789
chomp(my $hostname = `hostname`);
5790
$agent->hostname($hostname);
5791
$agent->username($ENV{USER} || $ENV{LOGNAME} || $who);
5793
# Try to create/update the Agent.
5795
while ( $_oktorun->() && $tries-- ) {
5796
if ( !$state->{init_action}++ && !$quiet ) {
5797
$logger->info($action eq 'put' ? "Updating agent " . $agent->name
5798
: "Creating new agent");
5800
my $agent_uri = eval {
5803
resources => $agent,
5806
if ( $EVAL_ERROR ) {
5807
my $code = $client->response->code;
5808
if ( $code && $code == 404 ) {
5809
my $api_ok = ping_api(
5813
$logger->fatal("API reports agent not found: the agent has been "
5814
. "deleted, or its UUID (" . ($agent->uuid || '?') . ") "
5815
. "is wrong. Check https://cloud.percona.com/agents for the "
5816
. "list of active agents.");
5819
$logger->warning("API is down.");
5822
elsif ( $code && $code == 403 ) {
5823
if ( !$state->{too_many_agents}++ ) {
5824
$logger->warning("API reports too many agents. Check "
5825
. "https://cloud.percona.com/agents for the list of "
5826
. "installed agents. Will try again $tries times, "
5827
. "but this warning will not be printed again.");
5831
$logger->warning($EVAL_ERROR);
5834
elsif ( !$agent_uri ) {
5835
$logger->warning("No URI for Agent " . $agent->name);
5838
# The Agent URI will have been returned in the Location header
5839
# of the POST or PUT response. GET the Agent (even after PUT)
5840
# to get a link to the agent's config.
5842
$agent = $client->get(
5846
if ( $EVAL_ERROR ) {
5847
$logger->warning($EVAL_ERROR);
5855
$interval->(); # failure, try again
5859
delete $state->{init_action};
5860
delete $state->{too_many_agents};
5862
return $agent, $success;
5865
# Check and init the --lib dir. This dir is used to save the Agent resource
5866
# (/agent), Service resources (/services/), and crontab for services(/conrtab,
5870
have_required_args(\%args, qw(
5873
my $lib_dir = $args{lib_dir};
5876
my $verify = $args{verify};
5877
my $quiet = $args{quiet};
5879
$logger->info(($verify ? 'Verify' : 'Initializing') . " --lib $lib_dir")
5882
if ( ! -d $lib_dir ) {
5884
die "$lib_dir does not exist\n";
5887
$logger->info("$lib_dir does not exist, creating")
5889
_safe_mkdir($lib_dir);
5892
elsif ( ! -w $lib_dir ) {
5893
die "--lib $lib_dir is not writable.\n";
5896
foreach my $dir ( qw(services logs pids meta) ) {
5897
my $dir = "$lib_dir/$dir";
5900
die "$dir does not exist\n";
5903
$logger->info("$dir does not exist, creating")
5908
elsif ( ! -w $dir ) {
5909
die "$dir is not writable.\n";
5916
# ################################ #
5917
# Agent (main daemon) process subs #
5918
# ################################ #
5923
have_required_args(\%args, qw(
5928
my $api_key = $args{api_key};
5929
my $lib_dir = $args{lib_dir};
5930
my $cxn = $args{Cxn};
5933
my $agent_uuid = $args{agent_uuid};
5934
my $daemonize = $args{daemonize};
5935
my $pid_file = $args{pid_file};
5936
my $log_file = $args{log_file};
5937
my $_oktorun = $args{oktorun} || sub { return $oktorun };
5938
my $tries = $args{tries} || 1440; # 1440 * 60 = 1 day
5939
my $interval = $args{interval} || sub { sleep 60; };
5940
my $versions = $args{versions}; # for testing
5941
my $client = $args{client}; # for testing
5942
my $entry_links = $args{entry_links}; # for testing
5943
my $logger_client = $args{logger_client}; # for testing
5945
# $logger->info('Starting agent');
5947
# Daemonize first so all output goes to the --log.
5948
my $daemon = Daemon->new(
5949
daemonize => $daemonize,
5950
pid_file => $pid_file,
5951
log_file => $log_file,
5952
parent_exit => sub {
5953
my $child_pid = shift;
5954
print "pt-agent has daemonized and is running as PID $child_pid:
5956
--lib " . ($lib_dir || '') . "
5957
--log " . ($log_file || '') . "
5958
--pid " . ($pid_file || '') . "
5960
These values can change if a different configuration is received.
5966
# If we daemonized, the parent has already exited and we're the child.
5967
# We shared a copy of every Cxn with the parent, and the parent's copies
5968
# were destroyed but the dbhs were not disconnected because the parent
5969
# attrib was true. Now, as the child, set it false so the dbhs will be
5970
# disconnected when our Cxn copies are destroyed. If we didn't daemonize,
5971
# then we're not really a parent (since we have no children), so set it
5972
# false to auto-disconnect the dbhs when our Cxns are destroyed.
5976
# Make --lib and its subdirectories.
5979
lib_dir => $lib_dir,
5982
if ( $EVAL_ERROR ) {
5984
$logger->info("Error initializing --lib $lib_dir: $EVAL_ERROR. "
5985
. "Configure the agent to use a writeable --lib directory.");
5988
# Connect to the API and get entry links.
5989
if ( !$client || !$entry_links ) {
5990
($client, $entry_links, $logger_client) = get_api_client(
5991
api_key => $api_key,
5993
interval => $interval,
5996
if ( !$client || !$entry_links ) {
5997
die "Failed to initialize the API client. The API may be down. Please try again.\n";
5999
return unless $_oktorun->();
6001
# Do a version-check every time the agent starts. If versions
6002
# have changed, this can affect how services are implemented.
6003
# Since this is the only thing we use the Cxn for, get_versions()
6004
# connects and disconnect it, if possible. If not possible, the
6005
# MySQL version isn't sent in hopes that it becomes possible to get
6007
if ( !$versions || !$versions->{MySQL} ) {
6008
$versions = get_versions(
6012
return unless $_oktorun->();
6014
# Load and update the local (i.e. existing) agent, or create a new one.
6018
if ( $agent_uuid ) {
6019
$logger->info("Re-creating Agent with UUID $agent_uuid");
6020
$agent = Percona::WebAPI::Resource::Agent->new(
6021
uuid => $agent_uuid,
6022
versions => $versions,
6024
$action = 'put'; # update
6025
$link = $entry_links->{agents} . '/' . $agent->uuid;
6028
# First try to load the local agent.
6029
$agent = load_local_agent(
6030
lib_dir => $lib_dir,
6033
# Loaded local agent.
6034
$action = 'put'; # update
6035
$link = $entry_links->{agents} . '/' . $agent->uuid;
6036
$agent->{versions} = $versions;
6039
# No local agent and --agent-uuid wasn't give.
6040
$agent = Percona::WebAPI::Resource::Agent->new(
6041
versions => $versions,
6043
$action = 'post'; # create
6044
$link = $entry_links->{agents};
6049
($agent, $success) = init_agent(
6051
action => $action, # put or post
6055
interval => $interval,
6056
oktorun => $_oktorun, # optional
6059
die "Failed to initialize the agent. The API may be down. Please try again.\n";
6062
# Give the logger its client so that it will also POST every log entry
6063
# to /agent/{uuid}/log. This is done asynchronously by a thread so a
6064
# simple info("Hello world!") to STDOUT won't block if the API isn't
6065
# responding. -- Both client and log_link are required to enable this.
6066
if ( $logger->online_logging && $agent->links->{log} && $logger_client ) {
6067
$logger->start_online_logging(
6068
client => $logger_client,
6069
log_link => $agent->links->{log},
6071
$logger->debug("Log API enabled");
6076
lib_dir => $lib_dir,
6079
# Remove old service files. New instance of agent shouldn't inherit
6080
# anything from previous runs, in case previous runs were bad.
6081
my $service_files = "$lib_dir/services/*";
6082
foreach my $service_file ( glob $service_files ) {
6083
if ( unlink $service_file ) {
6084
$logger->debug("Removed $service_file");
6087
$logger->warning("Cannot remove $service_file: $OS_ERROR");
6093
lib_dir => $lib_dir,
6097
if ( $EVAL_ERROR ) {
6098
$logger->error("Error removing services from crontab: $EVAL_ERROR");
6108
# Run the agent, i.e. exec the main loop to check/update the config
6109
# and services. Doesn't return until the service is stopped or killed.
6113
have_required_args(\%args, qw(
6122
my $agent = $args{agent};
6123
my $client = $args{client};
6124
my $daemon = $args{daemon};
6125
my $interval = $args{interval};
6126
my $lib_dir = $args{lib_dir};
6127
my $safeguards = $args{safeguards};
6128
my $cxn = $args{Cxn};
6131
my $_oktorun = $args{oktorun} || sub { return $oktorun };
6133
$logger->info('Running agent ' . $agent->name);
6135
# #######################################################################
6137
# #######################################################################
6138
$state->{need_mysql_version} = 1;
6139
$state->{first_config} = 1;
6140
$state->{ready} = 0;
6141
my $first_config_interval = 20;
6142
$logger->info("Checking silently every $first_config_interval seconds"
6143
. " for the first config");
6149
while ( $_oktorun->() ) {
6150
($config, $lib_dir, $new_daemon, $success) = get_config(
6151
link => $agent->links->{config},
6155
lib_dir => $lib_dir,
6157
quiet => $state->{first_config},
6160
# Get services only if we successfully got the config because the services
6161
# may depened on the current config, specifically the --spool dir.
6162
if ( $success && $config && $config->links->{services} ) {
6163
if ( $state->{first_config} ) {
6164
delete $state->{first_config};
6167
if ( $new_daemon ) {
6168
# NOTE: Daemon objects use DESTROY to auto-remove their pid file
6169
# when they lose scope (i.e. ref count goes to zero). This
6170
# assignment destroys (old) $daemon, so it auto-removes the old
6171
# pid file. $new_daemon maintains scope and the new pid file
6172
# by becoming $daemon which was defined in the outer scope so
6173
# it won't destroy again when we leave this block. Fancy!
6174
# About sharing_pid_file: see the comment in apply_config().
6175
if ( $new_daemon->{sharing_pid_file} ) {
6176
$daemon->{pid_file_owner} = 0;
6177
delete $new_daemon->{sharing_pid_file};
6179
$daemon = $new_daemon;
6182
# Connect to MySQL, then check stuff.
6183
my $o = new OptionParser();
6186
my $dp = $o->DSNParser();
6187
$dp->prop('set-vars', $o->set_vars());
6188
my $dsn = $dp->parse_options($o);
6190
$cxn->connect(dsn => $dsn);
6192
if ( $EVAL_ERROR ) {
6193
if ( !$state->{mysql_error}++ ) {
6194
$logger->warning("MySQL connection failure: $EVAL_ERROR");
6197
$logger->debug("MySQL connection failure: $EVAL_ERROR");
6199
$state->{have_mysql} = 0;
6200
$state->{need_mysql_version} = 1;
6203
if ( !$state->{have_mysql} ) {
6204
$logger->info("MySQL OK");
6206
$state->{have_mysql} = 1;
6207
check_if_mysql_restarted(
6210
if ( $state->{need_mysql_version} ) {
6211
$logger->debug("Need MySQL version");
6212
my $versions = get_versions(Cxn => $cxn);
6213
if ( $versions->{MySQL} ) {
6214
$agent->versions($versions);
6216
($agent, $updated_agent) = init_agent(
6219
link => $agent->links->{self},
6222
interval => sub { return; },
6225
if ( $updated_agent ) {
6226
$logger->debug("Got MySQL version");
6229
lib_dir => $lib_dir,
6231
if ( !$state->{ready} || $state->{mysql_error} ) {
6232
$logger->info('Agent OK');
6234
delete $state->{need_mysql_version};
6235
delete $state->{mysql_error};
6236
$state->{ready} = 1;
6240
if ( !$state->{mysql_error}++ ) {
6241
$logger->warning("Failed to get MySQL version");
6244
$logger->debug("Failed to get MySQL version");
6248
$cxn->dbh->disconnect();
6251
# Check the safeguards.
6252
my ($disk_space, $disk_space_ok);
6254
$disk_space = $safeguards->get_disk_space(
6255
filesystem => $config->options->{spool},
6257
$disk_space_ok = $safeguards->check_disk_space(
6258
disk_space => $disk_space,
6261
if ( $EVAL_ERROR ) {
6262
$logger->error("Error checking disk space: $EVAL_ERROR");
6265
if ( !$disk_space_ok ) {
6266
$logger->warning("Disk bytes free/percentage threshold: "
6267
. $safeguards->{disk_bytes_free}
6269
. $safeguards->{disk_pct_free});
6270
$logger->warning("Disk space is low, stopping all services:\n"
6272
if ( !$state->{all_services_are_stopped} ) {
6274
lib_dir => $lib_dir,
6277
$logger->warning('Services will restart when disk space "
6278
. "threshold checks pass');
6280
elsif ( $state->{ready} ) {
6281
($services, $success) = get_services(
6282
link => $config->links->{services},
6285
lib_dir => $lib_dir,
6286
services => $services,
6287
json => $args{json}, # optional, for testing
6288
bin_dir => $args{bin_dir}, # optional, for testing
6293
# If configured, wait the given interval. Else, retry more
6294
# quickly so we're ready to go soon after we're configured.
6296
!$state->{ready} ? (20, 1)
6297
: $config ? ($config->options->{'check-interval'}, 0)
6298
: ($first_config_interval , 1) # 1=quiet
6303
lib_dir => $lib_dir,
6306
# This shouldn't happen until the service is stopped/killed.
6307
$logger->info('Agent ' . $agent->name . ' has stopped');
6313
have_required_args(\%args, qw(
6320
my $link = $args{link};
6321
my $agent = $args{agent};
6322
my $client = $args{client};
6323
my $daemon = $args{daemon};
6324
my $lib_dir = $args{lib_dir};
6327
my $config = $args{config}; # may not be defined yet
6328
my $quiet = $args{quiet};
6333
$logger->debug('Getting agent config') unless $quiet;
6334
my $new_config = eval {
6339
if ( my $e = $EVAL_ERROR ) {
6341
if ($e->isa('Percona::WebAPI::Exception::Request')) {
6342
if ( $e->status == 404 ) {
6343
my $api_ok = ping_api(
6348
lib_dir => $lib_dir,
6350
$logger->fatal("API reports agent not found: the agent has been "
6351
. "deleted, or its UUID (" . ($agent->uuid || '?') . ") "
6352
. "is wrong. Check https://cloud.percona.com/agents for a "
6353
. "list of active agents.");
6357
$logger->_log(0, 'WARNING', "Cannot get agent config: API is down. "
6358
. "Will try again.");
6363
$logger->_log(0, 'WARNING', "Cannot get agent config: API error: $e. "
6364
. "Will try again.")
6367
elsif ($e->isa('Percona::WebAPI::Exception::Resource')) {
6368
$logger->error("Invalid agent config: $e");
6372
$logger->error("Internal error getting agent config: $e");
6378
$logger->debug("Running config: " . ($config ? $config->ts : ''));
6379
$logger->debug("Current config: " . $new_config->ts);
6381
if ( !$config || $new_config->ts > $config->ts ) {
6382
($lib_dir, $new_daemon) = apply_config(
6384
old_config => $config,
6385
new_config => $new_config,
6386
lib_dir => $lib_dir,
6389
$config = $new_config;
6391
$logger->info('Config ' . $config->ts . ' applied');
6393
$state->{need_mysql_version} = 1;
6397
$logger->debug('Config has not changed') unless $quiet;
6400
if ( $EVAL_ERROR ) {
6402
$logger->warning("Failed to apply config " . $new_config->ts
6403
. ": $EVAL_ERROR Will try again.");
6407
return ($config, $lib_dir, $new_daemon, $success);
6413
have_required_args(\%args, qw(
6419
my $agent = $args{agent};
6420
my $new_config = $args{new_config};
6421
my $lib_dir = $args{lib_dir};
6422
my $daemon = $args{daemon};
6425
my $old_config = $args{old_config};
6427
$logger->debug('Applying config ' . $new_config->ts);
6429
# If the --lib dir has changed, init the new one and re-write
6430
# the Agent resource in it.
6431
my $new_lib_dir = $new_config->options->{lib};
6432
if ( ($new_lib_dir ne $lib_dir) || $state->{first_config} ) {
6433
$logger->info($state->{first_config} ? "Applying first config"
6434
: "New --lib direcotry: $new_lib_dir");
6436
lib_dir => $new_lib_dir,
6439
# TODO: copy old-lib/services/* to new-lib/services/ ?
6441
# Save agent as --lib/agent so next time the tool starts it
6442
# loads the agent from the latest --lib dir.
6445
lib_dir => $new_lib_dir,
6449
# If --pid or --log has changed, we need to "re-daemonize",
6450
# i.e. change these files while running, but the program
6451
# does _not_ actually restart.
6453
my $make_new_daemon = 0;
6454
my $old_pid = $daemon->{pid_file} || '';
6455
my $old_log = $daemon->{log_file} || '';
6456
my $new_pid = $new_config->options->{pid} || '';
6457
my $new_log = $new_config->options->{log} || '';
6458
if ( $old_pid ne $new_pid ) {
6459
$logger->info('NOTICE: Changing --pid file from ' . ($old_pid || '(none)')
6460
. ' to ' . ($new_pid || '(none)'));
6461
$make_new_daemon = 1;
6463
if ( $daemon->{daemonize} ) {
6464
# --log only matters if we're daemonized
6465
if ( $old_log ne $new_log ) {
6466
$logger->info('NOTICE: Changing --log file from '
6467
. ($old_log || '(none)') . ' to ' . ($new_log || '(none)'));
6468
$make_new_daemon = 1;
6471
if ( $make_new_daemon ) {
6472
# We're either already daemonized or we didn't daemonize in the first
6473
# place, so daemonize => 0 here. Also, if log hasn't changed, the
6474
# effect is simply closing and re-opening the same log.
6475
# TODO: If log changes but pid doesn't? will probably block itself.
6476
$new_daemon = Daemon->new(
6478
pid_file => $new_pid,
6479
log_file => $new_log,
6480
force_log_file => $daemon->{daemonize},
6485
if ( $daemon->{daemonize} && $old_log ne $new_log ) {
6486
$logger->info('New log file, previous was '
6487
. ($old_log || 'unset'));
6489
if ( $old_pid eq $new_pid ) {
6490
# If the PID file has not, then the old/original daemon and
6491
# the new daemon are sharing the same pid file. The old one
6492
# created it, but the new one will continue to hold it when
6493
# the old one goes away. Set sharing_pid_file to signal to
6494
# the caller that they need to set old daemon pid_file_owner=0
6495
# so it does not auto-remove the shared pid file when it goes
6497
$new_daemon->{sharing_pid_file} = 1;
6500
if ( $EVAL_ERROR ) {
6501
die "Error changing --pid and/or --log: $EVAL_ERROR\n";
6505
# Save config in $HOME/.pt-agent.conf if successful.
6507
config => $new_config,
6510
return ($new_lib_dir || $lib_dir), $new_daemon;
6513
# Write a Config resource to a Percona Toolkit config file,
6514
# usually $HOME/pt-agent.conf.
6518
have_required_args(\%args, qw(
6521
my $config = $args{config};
6523
my $file = get_config_file();
6524
$logger->info("Writing config to $file");
6526
# Get the api-key line if any; we don't want to/can't clobber this.
6530
open my $fh, "<", $file
6531
or die "Error opening $file: $OS_ERROR";
6532
my $contents = do { local $/ = undef; <$fh> };
6534
($api_key) = $contents =~ m/^(api-key=\S+)$/m;
6535
($no_log_api) = $contents =~ m/^(no-log-api)$/m;
6538
# Re-write the api-key, if any, then write the config.
6539
open my $fh, '>', $file
6540
or die "Error opening $file: $OS_ERROR";
6542
print { $fh } $api_key, "\n"
6543
or die "Error writing to $file: $OS_ERROR";
6545
if ( $no_log_api ) {
6546
print { $fh } $no_log_api, "\n"
6547
or die "Error writing to $file: $OS_ERROR";
6549
print { $fh } as_config($config)
6550
or die "Error writing to $file: $OS_ERROR";
6552
or die "Error closing $file: $OS_ERROR";
6559
have_required_args(\%args, qw(
6566
my $link = $args{link};
6567
my $agent = $args{agent};
6568
my $client = $args{client};
6569
my $lib_dir = $args{lib_dir};
6570
my $prev_services = $args{services};
6575
$logger->debug('Getting services');
6576
my $curr_services = $client->get(
6580
if ( !$curr_services ) {
6581
$logger->error("GET $link did not return anything, "
6582
. "expected a list of services");
6584
elsif ( !scalar @$curr_services && !scalar keys %$prev_services ) {
6585
$logger->debug("No services are enabled for this agent");
6587
# Remove these state that no longer matter if there are no services.
6588
if ( $state->{mysql_restarted} ) {
6589
$state->{last_uptime} = 0;
6590
$state->{last_uptime_check} = 0;
6591
delete $state->{mysql_restarted};
6593
if ( $state->{all_services_are_stopped} ) {
6594
delete $state->{all_services_are_stopped};
6598
if ( $state->{all_services_are_stopped} ) {
6599
$logger->info('Restarting services after safeguard shutdown');
6600
# If prev_services is empty, then it's like agent startup:
6601
# get all the latest services and start them, and remove
6602
# any old services. We could just start-* the services we
6603
# already have, but since they were shut down due to a safeguard,
6604
# maybe (probably) they've changed.
6605
$prev_services = {};
6606
delete $state->{all_services_are_stopped};
6608
elsif ( my $ts = $state->{mysql_restarted} ) {
6609
$logger->info("Restarting services after MySQL restart at $ts");
6610
$prev_services = {};
6611
$state->{last_uptime} = 0;
6612
$state->{last_uptime_check} = 0;
6613
delete $state->{mysql_restarted};
6616
# Determine which services are new (added), changed/updated,
6618
my $sorted_services = sort_services(
6619
prev_services => $prev_services,
6620
curr_services => $curr_services,
6623
# First, stop and remove services. Do this before write_services()
6624
# because this call looks for --lib/services/stop-service which
6625
# write_services() removes. I.e. use the service's stop- meta
6626
# counterpart (if any) before we remove the service.
6627
my $removed_ok = apply_services(
6629
services => $sorted_services->{removed},
6630
lib_dir => $lib_dir,
6631
bin_dir => $args{bin_dir}, # optional, for testing
6632
exec_cmd => $args{exec_cmd}, # optional, for testing
6635
# Second, save each service in --lib/services/. Do this before
6636
# the next calls to apply_services() because those calls look for
6637
# --lib/services/start-service which won't exist for new services
6638
# until written by this call.
6640
sorted_services => $sorted_services,
6641
lib_dir => $lib_dir,
6642
json => $args{json}, # optional, for testing
6645
# Start new services and restart existing updated services.
6646
# Do this before calling schedule_services() so that, for example,
6647
# start-query-history is ran before query-history is scheduled
6648
# and starts running.
6650
# Run services with the run_once flag. Unlike apply_services(),
6651
# this call runs the service directly, whether it's meta or not,
6652
# then it removes it from the services hashref so there's no
6653
# chance of running it again unless it's received again.
6654
apply_services_once(
6655
services => $sorted_services->{services},
6656
lib_dir => $lib_dir,
6657
bin_dir => $args{bin_dir}, # optional, for testing
6658
exec_cmd => $args{exec_cmd}, # optional, for testing
6661
# Start new services.
6662
my $started_ok = apply_services(
6664
services => $sorted_services->{added},
6665
lib_dir => $lib_dir,
6666
bin_dir => $args{bin_dir}, # optional, for testing
6667
exec_cmd => $args{exec_cmd}, # optional, for testing
6670
# Restart existing updated services.
6671
my $restarted_ok = apply_services(
6672
action => 'restart',
6673
services => $sorted_services->{updated},
6674
lib_dir => $lib_dir,
6675
bin_dir => $args{bin_dir}, # optional, for testing
6676
exec_cmd => $args{exec_cmd}, # optional, for testing
6679
# Schedule any services with a run_schedule or spool_schedule.
6680
# This must be called last, after write_services() and
6681
# apply_services() because, for example, a service schedule
6682
# to run at */5 may run effectively immediate if we write
6683
# the new crontab at 00:04:59, so everything has to be
6684
# ready to go at this point.
6685
if ( scalar @$removed_ok
6686
|| scalar @$started_ok
6687
|| scalar @$restarted_ok )
6693
@{$sorted_services->{unchanged}},
6695
lib_dir => $lib_dir,
6696
bin_dir => $args{bin_dir}, # optional, for testing
6697
exec_cmd => $args{exec_cmd}, # optional, for testing
6700
$logger->info('Services OK');
6703
$logger->debug('Services have not changed');
6705
# TODO: probably shouldn't keep re-assigning this unless necessary
6706
$prev_services = $sorted_services->{services};
6710
if ( $EVAL_ERROR ) {
6711
$logger->warning($EVAL_ERROR);
6714
return $prev_services, $success;
6720
have_required_args(\%args, qw(
6724
my $prev_services = $args{prev_services}; # hashref
6725
my $curr_services = $args{curr_services}; # arrayref
6727
my $services = {}; # curr_services as hashref keyed on service name
6733
foreach my $service ( @$curr_services ) {
6734
my $name = $service->name;
6735
$services->{$name} = $service;
6737
# apply_services() only needs real services, from which it can infer
6738
# certain meta-services like "start-foo" for real service "foo",
6739
# but write_services() needs meta-services too so it can know to
6740
# remove their files from --lib/services/.
6742
if ( !exists $prev_services->{$name} ) {
6743
push @added, $service;
6745
elsif ( $service->ts > $prev_services->{$name}->ts ) {
6746
push @updated, $service;
6749
push @unchanged, $service;
6752
if ( scalar keys %$prev_services ) {
6753
@removed = grep { !exists $services->{$_->name} } values %$prev_services;
6756
if ( scalar @added ) {
6757
$logger->info("Added services: "
6758
. join(', ', map { $_->name } @added));
6760
if ( scalar @updated ) {
6761
$logger->info("Services updated: "
6762
. join(', ', map { $_->name } @updated));
6764
if ( scalar @removed ) {
6765
$logger->info("Services removed: "
6766
. join(', ', map { $_->name } @removed));
6769
my $sorted_services = {
6770
services => $services,
6772
updated => \@updated,
6773
removed => \@removed,
6774
unchanged => \@unchanged,
6776
return $sorted_services;
6779
# Write each service to its own file in --lib/. Remove services
6780
# that are not longer implemented (i.e. not in the services array).
6781
sub write_services {
6784
have_required_args(\%args, qw(
6788
my $sorted_services = $args{sorted_services};
6789
my $lib_dir = $args{lib_dir};
6792
my $json = $args{json}; # for testing
6794
$lib_dir .= '/services';
6796
$logger->debug("Writing services to $lib_dir");
6798
# Save current, active services.
6799
foreach my $service (
6800
@{$sorted_services->{added}}, @{$sorted_services->{updated}}
6802
my $file = $lib_dir . '/' . $service->name;
6803
my $action = -f $file ? 'Updated' : 'Added';
6804
open my $fh, '>', $file
6805
or die "Error opening $file: $OS_ERROR";
6806
print { $fh } as_json($service, with_links => 1, json => $json)
6807
or die "Error writing to $file: $OS_ERROR";
6809
or die "Error closing $file: $OS_ERROR";
6810
$logger->info("$action $file");
6813
# Remove old services.
6814
foreach my $service ( @{$sorted_services->{removed}} ) {
6815
my $file = $lib_dir . '/' . $service->name;
6818
or die "Error removing $file: $OS_ERROR";
6819
$logger->info("Removed $file");
6826
# Write Service->run_schedule and Service->spool_schedule lines to crontab,
6827
# along with any other non-pt-agent lines, then reload crontab.
6828
sub schedule_services {
6831
have_required_args(\%args, qw(
6835
my $services = $args{services};
6836
my $lib_dir = $args{lib_dir};
6839
my $quiet = $args{quiet};
6840
my $exec_cmd = $args{exec_cmd} || sub { return system(@_) };
6842
$logger->info("Scheduling services") unless $quiet;
6844
# Only schedule "periodic" services, i.e. ones that run periodically,
6846
my @periodic_services = grep { $_->run_schedule || $_->spool_schedule }
6848
my $new_crontab = make_new_crontab(
6850
services => \@periodic_services,
6852
$logger->info("New crontab:\n" . $new_crontab || '') unless $quiet;
6854
my $crontab_file = "$lib_dir/crontab";
6855
open my $fh, '>', $crontab_file
6856
or die "Error opening $crontab_file: $OS_ERROR";
6857
print { $fh } $new_crontab
6858
or die "Error writing to $crontab_file: $OS_ERROR";
6860
or die "Error closing $crontab_file: $OS_ERROR";
6862
my $err_file = "$lib_dir/crontab.err";
6863
my $retval = $exec_cmd->("crontab $crontab_file > $err_file 2>&1");
6865
my $error = -f $err_file ? `cat $err_file` : '';
6866
die "Error setting new crontab: $error";
6872
# Combine Service->run_schedule and (optionally) Service->spool_schedule
6873
# lines with non-pt-agent lines, i.e. don't clobber the user's other
6875
sub make_new_crontab {
6878
have_required_args(\%args, qw(
6881
my $services = $args{services};
6884
my $crontab_list = defined $args{crontab_list} ? $args{crontab_list}
6885
: `crontab -l 2>/dev/null`;
6886
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir}
6890
= grep { $_ !~ m/pt-agent (?:--run-service|--send-data)/ }
6891
split("\n", $crontab_list);
6892
PTDEBUG && _d('Other crontab lines:', Dumper(\@other_lines));
6894
my $env_vars = env_vars();
6897
foreach my $service ( @$services ) {
6898
if ( $service->run_schedule ) {
6899
push @pt_agent_lines,
6900
$service->run_schedule
6901
. ($env_vars ? " $env_vars" : '')
6902
. " ${bin_dir}pt-agent --run-service "
6905
if ( $service->spool_schedule ) {
6906
push @pt_agent_lines,
6907
$service->spool_schedule
6908
. ($env_vars ? " $env_vars" : '')
6909
. " ${bin_dir}pt-agent --send-data "
6913
PTDEBUG && _d('pt-agent crontab lines:', Dumper(\@pt_agent_lines));
6915
my $new_crontab = join("\n", @other_lines, @pt_agent_lines) . "\n";
6916
$logger->debug("New crontab: " . ($new_crontab || ''));
6918
return $new_crontab;
6921
# Start real services, i.e. non-meta services. A real service is like
6922
# "query-history", which probably has meta-services like "start-query-history"
6923
# and "stop-query-history". We infer these start/stop meta-services
6924
# from the real service's name. A service doesn't require meta-services;
6925
# there may be nothing to do to start it, in which case the real service
6926
# starts running due to its run_schedule and schedule_services().
6927
sub apply_services {
6929
have_required_args(\%args, qw(
6934
my $action = $args{action};
6935
my $services = $args{services};
6936
my $lib_dir = $args{lib_dir};
6939
my $bin_dir = defined $args{bin_dir} ? "$args{bin_dir}"
6941
my $exec_cmd = $args{exec_cmd} || sub { return system(@_) };
6943
$bin_dir .= '/' unless $bin_dir =~ m/\/$/;
6945
my $env_vars = env_vars();
6946
my $log = "$lib_dir/logs/start-stop.log";
6947
my $cmd_fmt = ($env_vars ? "$env_vars " : '')
6948
. $bin_dir . "pt-agent --run-service %s >> $log 2>&1";
6952
foreach my $service ( @$services ) {
6953
next if $service->meta; # only real services
6955
my $name = $service->name;
6957
# To restart, one must first stop, then start afterwards.
6958
if ( $action eq 'stop' || $action eq 'restart' ) {
6959
if ( -f "$lib_dir/services/stop-$name" ) {
6960
if ( $action eq 'stop' ) {
6961
# If all we're doing is stopping services, then always
6962
# returned them as "applied OK" even if they fail to run
6963
# because the caller uses returns values to know to
6964
# update crontab. So if stop-foo fails, at least we'll
6965
# still remove --run-service foo from crontab.
6966
push @applied_ok, $service;
6968
my $cmd = sprintf $cmd_fmt, "stop-$name";
6969
$logger->info("Stopping $name: $cmd");
6970
my $cmd_exit_status = $exec_cmd->($cmd);
6971
if ( $cmd_exit_status != 0 ) {
6972
$logger->warning("Error stopping $name, check $log and "
6973
. "$lib_dir/logs/$name.run");
6974
# This doesn't matter for stop, but for restart a failure
6975
# to first stop means we shouldn't continue and try to start
6976
# the service (since it hasn't been stopped yet).
6982
if ( $action eq 'start' || $action eq 'restart' ) {
6983
# Remove old meta files. Meta files are generally temporary
6984
# in any case, persisting info from one interval to the next.
6985
# If the service has changed (e.g., report interval is longer),
6986
# there's no easy way to tranistion from old metadata to new,
6987
# so we just rm the old metadata and start anew.
6988
my $meta_files = "$lib_dir/meta/$name*";
6989
foreach my $meta_file ( glob $meta_files ) {
6990
if ( unlink $meta_file ) {
6991
$logger->info("Removed $meta_file");
6994
$logger->warning("Cannot remove $meta_file: $OS_ERROR");
6998
# Start the service and wait for it to exit. If it dies
6999
# really early (before it really begins), our log file will
7000
# have the error; else, the service should automatically
7001
# switch to its default log file ending in ".run".
7002
if ( -f "$lib_dir/services/start-$name" ) {
7003
my $cmd = sprintf $cmd_fmt, "start-$name";
7004
$logger->info("Starting $name: $cmd");
7005
my $cmd_exit_status = $exec_cmd->($cmd);
7006
if ( $cmd_exit_status != 0 ) {
7007
$logger->warning("Error starting $name, check $log and "
7008
."$lib_dir/logs/$name.run");
7011
push @applied_ok, $service;
7012
$logger->info("Started $name");
7017
return \@applied_ok;
7020
sub apply_services_once {
7022
have_required_args(\%args, qw(
7026
my $services = $args{services};
7027
my $lib_dir = $args{lib_dir};
7030
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir}
7032
my $exec_cmd = $args{exec_cmd} || sub { return system(@_) };
7034
my $env_vars = env_vars();
7035
my $log = "$lib_dir/logs/run-once.log";
7036
my $cmd_fmt = ($env_vars ? "$env_vars " : '')
7037
. $bin_dir . "pt-agent --run-service %s >> $log 2>&1";
7041
foreach my $name ( sort keys %$services ) {
7042
my $service = $services->{$name};
7043
next unless $service->run_once;
7045
delete $services->{$name};
7047
my $cmd = sprintf $cmd_fmt, $name;
7048
$logger->info("Running $name: $cmd");
7049
my $cmd_exit_status = $exec_cmd->($cmd);
7050
if ( $cmd_exit_status != 0 ) {
7051
$logger->error("Error running $name, check $log and "
7052
."$lib_dir/logs/$name.run");
7055
push @ran_ok, $service;
7056
$logger->info("Ran $name");
7062
# ########################## #
7063
# --run-service process subs #
7064
# ########################## #
7069
have_required_args(\%args, qw(
7076
my $api_key = $args{api_key};
7077
my $service = $args{service};
7078
my $lib_dir = $args{lib_dir};
7079
my $spool_dir = $args{spool_dir};
7080
my $cxn = $args{Cxn};
7083
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir} : "$FindBin::Bin/";
7084
my $agent_api = $args{agent_api};
7085
my $client = $args{client}; # for testing
7086
my $agent = $args{agent}; # for testing
7087
my $entry_links = $args{entry_links}; # for testing
7088
my $json = $args{json}; # for testing
7089
my $prefix = $args{prefix} || int(time); # for testing
7090
my $max_data = $args{max_data} || MAX_DATA_FILE_SIZE;
7092
my $start_time = time;
7094
# Can't do anything with the lib dir. Since we haven't started
7095
# logging yet, cron should capture this error and email the user.
7097
lib_dir => $lib_dir,
7098
verify => 1, # die unless ok, don't create
7102
# Load the Service object from local service JSON file.
7103
# $service changes from a string scalar to a Service object.
7104
$service = load_service(
7105
service => $service,
7106
lib_dir => $lib_dir,
7108
my $service_name = $service->name;
7110
my $daemon = Daemon->new(
7111
daemonize => 0, # no need: we're running from cron
7112
pid_file => "$lib_dir/pids/$service_name.$PID",
7113
log_file => "$lib_dir/logs/$service_name.run",
7114
force_log_file => 1,
7118
if ( $service->meta ) {
7119
$logger->service($service_name);
7122
$logger->service("$service_name run");
7124
$logger->info("Running $service_name");
7126
# Connect to Percona, get entry links.
7128
if ( $agent_api && (!$client || !$entry_links) ) {
7129
($client, $entry_links, $logger_client) = get_api_client(
7130
api_key => $api_key,
7132
interval => sub { return 2; },
7134
if ( !$client || !$entry_links ) {
7136
$logger->_log(0, 'WARNING', "Failed to connect to Percona Web API");
7140
# Load and update the local (i.e. existing) agent, or create a new one.
7142
# If this fails, there's no local agent, but that shouldn't happen
7143
# because a local agent originally scheduled this --send-data process.
7144
# Maybe that agent was deleted from the system but the crontab entry
7145
# was not and was left running.
7146
$agent = load_local_agent (
7147
lib_dir => $lib_dir,
7150
$logger->fatal("No agent exists ($lib_dir/agent) and --agent-uuid was "
7151
. "not specified. Check that the agent is properly installed.");
7155
# Start online logging, if possible.
7156
if ( $logger->online_logging && $agent_api && $client && $entry_links && $entry_links->{agents} ) {
7159
link => $entry_links->{agents} . '/' . $agent->uuid,
7162
if ( $EVAL_ERROR ) {
7163
$logger->info("Failed to get agent for online logging: $EVAL_ERROR");
7166
my $log_link = $agent->links->{log};
7167
$logger->data_ts($prefix) unless $service->meta;
7168
$logger->start_online_logging(
7169
client => $logger_client,
7170
log_link => $log_link,
7172
$logger->debug("Log API enabled");
7176
$logger->_log(0, 'INFO', "File logging only");
7179
# Check if any task spools data or uses MySQL. Any task that spools
7180
# should also use metadata because all data samples have at least a
7181
# start_ts and end_ts as metadata.
7182
my $tasks = $service->tasks;
7185
foreach my $task ( @$tasks ) {
7186
$use_spool = 1 if ($task->output || '') eq 'spool';
7187
$use_mysql = 1 if $task->query;
7190
# $data_dir will be undef if $use_spool is undef; that's ok because
7191
# only $tmp_dir is always needed.
7192
my ($data_dir, $tmp_dir) = init_spool_dir(
7193
spool_dir => $spool_dir,
7194
service => $use_spool ? $service->name : undef,
7197
# Connect to MySQL or quit.
7200
$logger->debug("Connecting to MySQL");
7206
if ( my $e = $EVAL_ERROR ) {
7207
$logger->debug("Cannot connect to MySQL: $e");
7215
$logger->error("Cannot run " . $service->name . " because it requires "
7216
. "MySQL but failed to connect to MySQL: " . ($last_error || '(no error)'));
7221
# Run the tasks, spool any data.
7223
my $recursive_service = '--run-service ' . $service->name;
7224
my $data_file = $prefix . '.' . $service->name . '.data';
7225
my $tmp_data_file = "$tmp_dir/$data_file";
7227
my $metadata = { data_ts => $prefix };
7229
my $env_vars = env_vars();
7232
foreach my $task ( @$tasks ) {
7233
# Set up the output file, i.e. where this run puts its results.
7234
# Runs can access each other's output files. E.g. run0 may
7235
# write to fileX, then subsequent tasks can access that file
7236
# with the special var __RUN_N_OUTPUT__ where N=0. Output files
7237
# have this format: (prefix.)service.type(.n), where prefix is
7238
# an optional unique ID for this run (usually a Unix ts); service
7239
# is the service name; type is "data", "tmp", "meta", etc.; and
7240
# n is an optional ID or instance of the type. The .data is the
7241
# only file required: it's the data sent by send_data().
7242
my $task_output_file = "$tmp_dir/$prefix."
7244
. ".output.$taskno";
7248
my ($store_key, $store_key_value_tuple);
7250
my $output = $task->output || '';
7251
if ( $output eq 'spool' ) {
7252
$output_file = $tmp_data_file;
7254
elsif ( $output =~ m/^stage:(\S+)/ ) {
7255
my $file_suffix = $1;
7256
$output_file = "$tmp_dir/$prefix." . $service->name . "$file_suffix";
7258
elsif ( $output =~ m/^meta:(\S+)/ ) {
7260
$output_file = "$lib_dir/meta/" . $service->name . ".meta.$attrib";
7262
elsif ( $output =~ m/^join:(.)$/ ) {
7264
$output_file = $task_output_file;
7266
elsif ( $output =~ m/store:key:([\w-]+)/ ) {
7268
$output_file = $task_output_file;
7270
elsif ( $output eq 'store:output' ) {
7271
$store_key = $taskno;
7272
$output_file = $task_output_file;
7274
elsif ( $output eq 'store:key_value_tuple' ) {
7275
$store_key_value_tuple = 1;
7277
elsif ( $output eq 'store:output' ) {
7278
$store_key = $taskno;
7279
$output_file = $task_output_file;
7281
elsif ( $output =~ m/append:(\S+)/ ) {
7285
elsif ( $output eq 'tmp' ) {
7286
$output_file = $task_output_file;
7289
if ( !$output_file ) {
7290
$output_file = '/dev/null';
7291
push @output_files, undef,
7294
push @output_files, $output_file;
7296
PTDEBUG && _d("Task $taskno output:", Dumper(\@output_files));
7298
if ( my $query = $task->query ) {
7299
$query = replace_special_vars(
7301
spool_dir => $spool_dir,
7302
output_files => \@output_files, # __RUN_n_OUTPUT__
7303
service => $service->name, # __SERVICE__
7304
lib_dir => $lib_dir, # __LIB__
7305
meta_dir => "$lib_dir/meta", # __META__
7306
stage_dir => $tmp_dir, # __STAGE__
7307
store => $store, # __STORE_key__
7308
ts => $prefix, # __TS__
7309
bin_dir => $bin_dir, # __BIN_DIR__
7310
env => $env_vars, # __ENV__
7312
$logger->info($task->name . ": $query");
7316
if ( $join_char || $store_key_value_tuple ) {
7317
$rows = $cxn->dbh->selectall_arrayref($query);
7320
$cxn->dbh->do($query);
7323
if ( $EVAL_ERROR ) {
7324
$logger->error("Error executing $query: $EVAL_ERROR");
7329
$logger->debug('Query returned ' . scalar @$rows . ' rows');
7332
if ( !open($fh, '>', $output_file) ) {
7333
$logger->error("Cannot open $output_file: $OS_ERROR");
7336
foreach my $row ( @$rows ) {
7337
print { $fh } join($join_char,
7338
map { defined $_ ? $_ : 'NULL' } @$row), "\n"
7339
or $logger->error("Cannot write to $output_file: $OS_ERROR");
7342
or $logger->warning("Cannot close $output_file: $OS_ERROR");
7344
elsif ( $store_key_value_tuple ) {
7345
foreach my $row ( @$rows ) {
7346
$store->{$row->[0]} = defined $row->[1] ? $row->[1] : 'NULL';
7352
push @{$metadata->{tasks}}, {
7353
start_ts => ts($t0, 1),
7354
end_ts => ts($t1, 1),
7355
run_time => sprintf('%.6f', $t1 - $t0),
7358
elsif ( my $program = $task->program ) {
7359
# Create the full command line to execute, replacing any
7360
# special vars like __RUN_N_OUTPUT__, __TMPDIR__, etc.
7363
($append ? '>>' : '>'),
7366
$cmd = replace_special_vars(
7368
spool_dir => $spool_dir,
7369
output_files => \@output_files, # __RUN_n_OUTPUT__
7370
service => $service->name, # __SERVICE__
7371
lib_dir => $lib_dir, # __LIB__
7372
meta_dir => "$lib_dir/meta", # __META__
7373
stage_dir => $tmp_dir, # __STAGE__
7374
store => $store, # __STORE_key__
7375
ts => $prefix, # __TS__
7376
bin_dir => $bin_dir, # __BIN_DIR__
7377
env => $env_vars, # __ENV__
7379
$logger->debug("Task $taskno command: $cmd");
7381
if ( $cmd =~ m/$recursive_service/ ) {
7382
$logger->fatal("Recursive service detected: $cmd");
7383
die; # fatal() should die, but just in case
7390
my $value = slurp($output_file);
7391
chomp($value) if $value;
7392
$store->{$store_key} = $value;
7395
my $run_time = sprintf('%.6f', $t1 - $t0);
7396
my $cmd_exit_status = $CHILD_ERROR >> 8;
7397
$logger->info($task->name . ": $cmd (runtime: $run_time exit: $cmd_exit_status)");
7398
$exit_status |= $cmd_exit_status;
7400
push @{$metadata->{tasks}}, {
7401
start_ts => ts($t0, 1),
7402
end_ts => ts($t1, 1),
7403
run_time => $run_time,
7404
exit_status => $cmd_exit_status,
7407
if ( $cmd_exit_status == 200 && !$service->meta ) {
7408
# Equivalent to 0 for meta-services that need to stop early
7409
# but let the non-meta, i.e. real, parent service continue.
7411
elsif ( $cmd_exit_status == 253 ) {
7412
$logger->error($task->name . ' exit status not zero, '
7413
. 'stopping ' . $service->name . ' service');
7415
service => $service->name,
7416
lib_dir => $lib_dir,
7420
elsif ( $cmd_exit_status == 254 ) {
7421
$logger->error($task->name . ' exit status not zero, '
7422
. 'stopping all services');
7428
elsif ( $cmd_exit_status != 0 ) {
7429
$logger->info($task->name . ' exit status not zero, '
7430
. 'stopping tasks');
7435
$logger->error('Invalid Task resource:', Dumper($task));
7442
# Move the spool file from --spool/.tmp/ to --spool/<service>/
7443
# if 1) the service spools data and 2) there is data.
7444
my $file_size = (-s $tmp_data_file) || 0;
7445
$logger->debug("$tmp_data_file size: " . ($file_size || 0) . " bytes");
7446
if ( $use_spool && $file_size ) {
7447
# Save metadata about this sample _first_, because --send-data looks
7448
# for the data file first, then for a corresponding .meta file. If
7449
# we write the data file first, then we create a race condition: while
7450
# we're writing, --send-data could see the data file but not the
7451
# .meta file because we haven't written it yet. So writing the .meta
7452
# file first guarantees that if --send-data sees a data file, the
7453
# .meta already exists. (And there's no race condition on writing
7454
# the data file because we use a quasi-atomic system mv.)
7456
service => $service->name,
7458
metadata => $metadata,
7459
stage_dir => $tmp_dir,
7461
$metadata->{run_time} = sprintf('%.6f', time - $start_time);
7462
(my $meta_file = $data_file) =~ s/\.data/\.meta/;
7463
my $json_metadata = as_json($metadata, json => $json);
7465
data => $json_metadata,
7466
file => "$data_dir/$meta_file",
7469
if ( $file_size <= $max_data ) {
7470
# Use system mv instead of Perl File::Copy::move() because it's
7471
# unknown if the Perl version will do an optimized move, i.e.
7472
# simply move the inode, _not_ copy the file. A system mv on
7473
# the same filesystem is pretty much guaranteed to do an optimized,
7474
# i.e. quasi-atomic, move.
7475
my $cmd = "mv $tmp_data_file $data_dir";
7476
$logger->debug($cmd);
7478
my $cmd_exit_status = $CHILD_ERROR >> 8;
7479
if ( $cmd_exit_status != 0 ) {
7480
$logger->error("Move failed: $cmd")
7482
$exit_status |= $cmd_exit_status;
7485
$logger->error("Data file is larger than $max_data, skipping: "
7486
. ($json_metadata || ''));
7490
# Remove staged files. Anything to save should have been moved
7491
# from staging by a task.
7492
foreach my $file ( glob "$tmp_dir/$prefix." . $service->name . ".*" ) {
7494
or $logger->warning("Error removing $file: $OS_ERROR");
7497
$logger->info("Exit: $exit_status");
7498
return $exit_status; # returning global var for testing
7504
have_required_args(\%args, qw(
7508
my $service = $args{service};
7509
my $lib_dir = $args{lib_dir};
7511
my $service_file = "$lib_dir/services/$service";
7512
if ( ! -f $service_file ) {
7513
$logger->fatal("Cannot load $service: $service_file does not exist.");
7518
my $service_hash = JSON::decode_json(slurp($service_file));
7519
$service_obj = Percona::WebAPI::Resource::Service->new(%$service_hash);
7521
if ( $EVAL_ERROR ) {
7522
$logger->fatal("Cannot load $service: $EVAL_ERROR");
7525
return $service_obj;
7528
sub replace_special_vars {
7531
have_required_args(\%args, qw(
7543
my $cmd = $args{cmd};
7544
my $spool_dir = $args{spool_dir};
7545
my $output_files = $args{output_files};
7546
my $service = $args{service};
7547
my $lib_dir = $args{lib_dir};
7548
my $meta_dir = $args{meta_dir};
7549
my $stage_dir = $args{stage_dir};
7550
my $store = $args{store};
7552
my $bin_dir = $args{bin_dir};
7555
my $env = $args{env} || '';
7560
$new_cmd = join(' ',
7563
$word =~ s/__RUN_(\d+)_OUTPUT__/$output_files->[$1]/g;
7564
$word =~ s/__STORE_([\w-]+)__/$store->{$1}/g;
7565
$word =~ s/__TS__/$ts/g;
7566
$word =~ s/__LIB__/$lib_dir/g;
7567
$word =~ s/__META__/$meta_dir/g;
7568
$word =~ s/__STAGE__/$stage_dir/g;
7569
$word =~ s/__SERVICE__/$service/g;
7570
$word =~ s/__STAGE_FILE__/$stage_dir\/$ts.$service/g;
7571
$word =~ s/__META_FILE__/$meta_dir\/$service.meta/g;
7572
$word =~ s/__BIN_DIR__/$bin_dir/g;
7573
$word =~ s/__TRASH__/$spool_dir\/.trash/g;
7574
$word =~ s/__ENV__/$env/g;
7580
if ( $EVAL_ERROR ) {
7581
$logger->fatal("Error replacing " . ($word || '')
7582
. " in $cmd: $EVAL_ERROR");
7588
sub init_spool_dir {
7591
have_required_args(\%args, qw(
7594
my $spool_dir = $args{spool_dir};
7597
my $service = $args{service};
7598
my $quiet = $args{quiet};
7600
if ( !-d $spool_dir ) {
7601
$logger->info("$spool_dir does not exist, creating")
7603
_safe_mkdir($spool_dir);
7605
elsif ( !-w $spool_dir ) {
7606
die "$spool_dir is not writeable\n";
7609
foreach my $subdir ( $service, '.tmp', '.trash' ) {
7610
next unless $subdir; # service may be undef
7611
my $dir = "$spool_dir/$subdir";
7613
$logger->info("$dir does not exist, creating")
7617
elsif ( !-w $dir ) {
7618
die "$dir is not writeable\n";
7622
my $data_dir = $service ? "$spool_dir/$service" : undef;
7623
my $tmp_dir = "$spool_dir/.tmp";
7625
return $data_dir, $tmp_dir;
7631
have_required_args(\%args, qw(
7637
my $service = $args{service};
7638
my $prefix = $args{prefix};
7639
my $metadata = $args{metadata};
7640
my $stage_dir = $args{stage_dir};
7642
# Example filename: 123456.query-history.meta.stop_offset
7643
foreach my $file ( glob "$stage_dir/$prefix.$service.meta.*" ) {
7644
PTDEBUG && _d('metadata file:', $file);
7645
my ($attrib) = $file =~ m/\.meta\.(\S+)$/;
7646
my $value = slurp($file);
7647
chomp($value) if $value;
7648
PTDEBUG && _d('metadata', $attrib, '=', $value);
7649
$metadata->{$attrib} = $value;
7651
or $logger->warning("Cannot rm $file: $OS_ERROR");
7657
# ######################## #
7658
# --send-data process subs #
7659
# ######################## #
7661
# Send every file or directory in each service's directory in --spool/.
7662
# E.g. --spool/query-monitor should contain files with pt-query-digest
7663
# output. The per-service dirs are created in run_service().
7667
have_required_args(\%args, qw(
7673
my $api_key = $args{api_key};
7674
my $service = $args{service};
7675
my $lib_dir = $args{lib_dir};
7676
my $spool_dir = $args{spool_dir};
7679
my $interactive = $args{interactive};
7680
my $max_data = $args{max_data} || MAX_DATA_FILE_SIZE;
7681
my $agent = $args{agent}; # for testing
7682
my $client = $args{client}; # for testing
7683
my $entry_links = $args{entry_links}; # for testing
7684
my $json = $args{json}; # for testing
7685
my $delay = defined $args{delay} ? $args{delay} : rand(30); # for testing
7687
# Can't do anything with the lib dir. Since we haven't started
7688
# logging yet, cron should capture this error and email the user.
7690
lib_dir => $lib_dir,
7695
# Load the Service object from local service JSON file.
7696
# $service changes from a string scalar to a Service object.
7697
$service = load_service(
7698
service => $service,
7699
lib_dir => $lib_dir,
7701
my $service_name = $service->name;
7703
my ($service_dir) = init_spool_dir(
7704
spool_dir => $spool_dir,
7705
service => $service->name,
7708
my @data_files = glob "$service_dir/*.data";
7709
if ( scalar @data_files == 0 ) {
7710
$logger->debug("No $service_name data files to send");
7714
# Log all output to a file.
7715
my $daemon = Daemon->new(
7716
daemonize => 0, # no need: we're running from cron
7717
pid_file => "$lib_dir/pids/$service_name.send",
7718
log_file => "$lib_dir/logs/$service_name.send",
7719
force_log_file => $interactive ? 0 : 1,
7723
# Spool time is +/- [0, 1] minute from API, we randomize that further
7724
# by a few seconds to prevent all agents from sending at exactly
7725
# 00:01:00, 00:00:00, or 00:02:00.
7726
sleep $delay if $delay;
7728
$logger->service("$service_name send");
7729
my $data_link = $service->links->{data};
7730
$logger->info("Sending " . scalar @data_files . " data files ($data_link)");
7732
# Connect to Percona, get entry links.
7734
if ( !$client || !$entry_links ) {
7735
($client, $entry_links, $logger_client) = get_api_client(
7736
api_key => $api_key,
7738
interval => sub { sleep 10 },
7740
if ( !$client || !$entry_links ) {
7741
$logger->fatal("Failed to connect to Percona Web API")
7745
# Load and update the local (i.e. existing) agent, or create a new one.
7747
# If this fails, there's no local agent, but that shouldn't happen
7748
# because a local agent originally scheduled this --send-data process.
7749
# Maybe that agent was deleted from the system but the crontab entry
7750
# was not and was left running.
7751
$agent = load_local_agent (
7752
lib_dir => $lib_dir,
7755
$logger->fatal("No agent exists ($lib_dir/agent) and --agent-uuid was "
7756
. "not specified. Check that the agent is properly installed.");
7762
link => $entry_links->{agents} . '/' . $agent->uuid,
7765
if ( $EVAL_ERROR ) {
7766
$logger->fatal("Failed to get the agent: $EVAL_ERROR");
7768
my $log_link = $agent->links->{log};
7770
$logger->start_online_logging(
7771
client => $logger_client,
7772
log_link => $log_link,
7774
$logger->debug("Log API enabled");
7777
# Send data files in the service's spool dir.
7778
# Only iterator over data files because run_service() writes
7779
# them last to avoid a race condition with us. See the code
7780
# comment about writing the .meta file first in run_service().
7782
foreach my $data_file ( @data_files ) {
7783
(my $meta_file = $data_file) =~ s/\.data/.meta/;
7785
if ( $interactive ) {
7789
print "\n", `ls -l $data_file`;
7790
print "Send [Ynaq]: ";
7794
last DATA_FILE if $key eq 'q';
7795
next DATA_FILE if $key eq 'n';
7796
last PROMPT if $key eq 'y';
7797
if ( $key eq 'a' ) {
7798
print "Sending all remaining files...\n";
7802
warn "Invalid response: $key\n";
7806
my $data_file_size = (-s $data_file) || 0;
7807
if ( $data_file_size > $max_data ) {
7808
$logger->error("Not sending $data_file because it is too large: "
7809
. "$data_file_size > $max_data. This should not happen; "
7810
. "please contact Percona or file a bug, and verify that "
7811
. "all services are running properly.");
7816
# Send the file as-is. The --run-service process should
7817
# have written the data in a format that's ready to send.
7821
meta_file => $meta_file,
7822
data_file => $data_file,
7827
if ( my $e = $EVAL_ERROR ) {
7828
if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
7829
my $error_msg = $client->response->content;
7830
$logger->warning('Error ' . $e->status . " sending $data_file ($data_file_size bytes): "
7831
. ($error_msg || '(No error message from server)'));
7835
$logger->warning("Error sending $data_file ($data_file_size bytes): $e");
7840
# Data file sent successfully; now remove it. Failure here
7841
# is an error, not a warning, because if we can't remove the
7842
# file then we risk re-sending it, and currently we have no
7843
# way to determine if a file has been sent or not other than
7844
# whether it exists or not.
7846
unlink $data_file or die $OS_ERROR;
7848
if ( $EVAL_ERROR ) {
7850
$logger->warning("Sent $data_file but failed to remove it: "
7855
if ( -f $meta_file ) {
7856
unlink $meta_file or $logger->warning($OS_ERROR);
7859
$logger->info("Sent: $data_file ($data_file_size bytes)");
7862
$logger->info("Exit: $exit_status");
7863
return $exit_status; # returning global var for testing
7866
# Send the Agent and file's contents as-is as a multi-part POST.
7870
have_required_args(\%args, qw(
7876
my $client = $args{client};
7877
my $agent = $args{agent};
7878
my $data_file = $args{data_file};
7879
my $link = $args{link};
7882
my $meta_file = $args{meta_file};
7883
my $json = $args{json}; # for testing
7885
# Create a multi-part resource: first the Agent, so Percona knows
7886
# from whom the sample data is coming, then metadata about the sample,
7887
# then the actual sample data. Each part is separated by a special
7888
# boundary value. The contents of the data file are sent as-is
7889
# because here we don't know or care about the data; that's a job
7890
# for the PWS server.
7891
my $boundary = 'Ym91bmRhcnk'; # "boundary" in base64, without a trailing =
7893
my $agent_json = as_json($agent, json => $json);
7896
my $meta = -f $meta_file && -s $meta_file ? slurp($meta_file) : '';
7900
my $data = -s $data_file ? slurp($data_file) : '';
7904
# Put it all together:
7905
my $resource = <<CONTENT;
7907
Content-Disposition: form-data; name="agent"
7911
Content-Disposition: form-data; name="meta"
7915
Content-Disposition: form-data; name="data"
7921
# This will die if the server response isn't 2xx or 3xx. The caller,
7922
# send_data(), should catch this.
7925
resources => $resource,
7927
'Content-Type' => "multipart/form-data; boundary=$boundary",
7934
# ############################################ #
7935
# --status, --stop, --reload, and --reset subs #
7936
# ############################################ #
7941
have_required_args(\%args, qw(
7945
my $pid_file = $args{pid_file};
7946
my $lib_dir = $args{lib_dir};
7949
my $api_key = $args{api_key};
7950
my $crontab_list = defined $args{crontab_list} ? $args{crontab_list}
7951
: `crontab -l 2>/dev/null`;
7952
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir}
7955
# Check if pt-agent is running.
7958
pid_file => $pid_file,
7961
if ( my $e = $EVAL_ERROR ) {
7962
if ( !blessed($e) ) {
7963
$logger->warning("Sorry, an error occured while getting the pt-agent PID: $e");
7965
elsif ( $e->isa('Percona::Agent::Exception::PIDNotFound') ) {
7966
$logger->info("pt-agent is not running");
7968
elsif ( $e->isa('Percona::Agent::Exception::PIDNotRunning') ) {
7969
$logger->warning("$e. pt-agent may have stopped unexpectedly or crashed.");
7971
else { # unhandled exception
7972
$logger->warning("Sorry, an unknown exception occured while getting "
7973
. "the pt-agent PID: $e");
7977
$logger->info("pt-agent is running as PID $pid")
7981
$logger->info("API key: " . ($api_key || ''));
7984
$logger->warning("No API key is set");
7987
# Get the agent's info.
7988
if ( -f "$lib_dir/agent" ) {
7989
my $agent = JSON::decode_json(slurp("$lib_dir/agent"));
7990
foreach my $attrib ( qw(uuid hostname username) ) {
7991
$logger->info("Agent $attrib: " . ($agent->{$attrib} || ''));
7995
$logger->warning("$lib_dir/agent does not exist");
7998
# Parse pt-agent lines from crontab to see what's scheduled/running.
7999
my %scheduled = map {
8001
my ($service) = $line =~ m/pt-agent (?:--run-service|--send-data) (\S+)/;
8004
grep { $_ =~ m/pt-agent (?:--run-service|--send-data)/ }
8005
split("\n", $crontab_list);
8008
if ( -d "$lib_dir/services" ) {
8010
foreach my $service_file ( glob "$lib_dir/services/*" ) {
8011
my $service = eval {
8012
JSON::decode_json(slurp($service_file));
8014
if ( $EVAL_ERROR ) {
8015
$logger->warning("$service_file is corrupt");
8018
$service = Percona::WebAPI::Resource::Service->new(%$service);
8019
next if $service->meta; # only real services
8020
$have_service{$service->name} = 1;
8021
if ( $scheduled{$service->name} ) {
8023
$logger->info($service->name . " is running");
8026
$logger->warning($service->name . " is running but pt-agent is not");
8031
$logger->warning($service->name . " is not running");
8034
$logger->info($service->name . " has stopped");
8040
$logger->warning("$lib_dir/services does not exist");
8043
# Look for services that are still scheduled/running but that we'll
8044
# don't/shouldn't have. This can happen if the crontab gets messed
8045
# up, --stop fails, etc.
8046
foreach my $scheduled_service ( sort keys %scheduled ) {
8047
if ( !$have_service{$scheduled_service} ) {
8048
$logger->warning("$scheduled_service is running but "
8049
. "$lib_dir/services/$scheduled_service does not exist");
8059
have_required_args(\%args, qw(
8063
my $pid_file = $args{pid_file};
8064
my $lib_dir = $args{lib_dir};
8068
# Get the agent's PID and kill it. If the PID file doesn't
8069
# exist for some reason, get_agent_pid() will attempt to find
8070
# pt-agent --daemonize in ps. And if pt-agent doesn't respond
8071
# to the TERM signal after a short while, we kill it with
8075
pid_file => $pid_file,
8078
if ( my $e = $EVAL_ERROR ) {
8079
if ( !blessed($e) ) {
8080
$logger->warning("Sorry, an error occured while getting the pt-agent PID: $e");
8082
elsif ( $e->isa('Percona::Agent::Exception::PIDNotFound') ) {
8083
$logger->info("pt-agent is not running");
8086
elsif ( $e->isa('Percona::Agent::Exception::PIDNotRunning') ) {
8087
$logger->warning("$e. pt-agent may have stopped unexpectedly or crashed.");
8090
else { # unhandled exception
8091
$logger->warning("Sorry, an unknown exception occured while getting "
8092
. "the pt-agent PID: $e");
8096
$logger->info("Stopping pt-agent...");
8100
$running = kill 0, $pid;
8104
$running = kill 0, $pid;
8106
$logger->warning("pt-agent did not respond to the TERM signal, using "
8107
. "the KILL signal...");
8110
$running = kill 0, $pid;
8114
$running = kill 0, $pid;
8117
$logger->warning("pt-agent did not response to the KILL signal");
8120
$logger->info("Killed pt-agent");
8125
$logger->info("pt-agent has stopped");
8129
# pt-agent should remove its own PID file, but in case it didn't,
8130
# (e.g we had to kill -9 it), we remove the PID file manually.
8131
if ( -f $pid_file ) {
8133
or $logger->warning("Cannot remove $pid_file: $OS_ERROR. Remove "
8134
. "this file manually.");
8139
lib_dir => $lib_dir,
8142
# TODO: kill --lib/pids/*
8147
sub stop_all_services {
8150
have_required_args(\%args, qw(
8153
my $lib_dir = $args{lib_dir};
8156
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir}
8159
# Un-schedule all services, i.e. remove them from the user's crontab,
8160
# leaving the user's other tasks untouched.
8161
$logger->info("Removing all services from crontab...");
8165
lib_dir => $lib_dir,
8169
if ( $EVAL_ERROR ) {
8170
$logger->error("Error removing services from crontab: $EVAL_ERROR");
8173
# Stop all real services by running their stop-<service> meta-service.
8174
# If a real service doesn't have a stop-<service> meta-service, then
8175
# presumably nothing needs to be done to stop it other than un-scheduling
8176
# it, which we've already done.
8177
if ( -d "$lib_dir/services" ) {
8178
my $env_vars = env_vars();
8181
foreach my $file ( glob "$lib_dir/services/stop-*" ) {
8182
my $service = basename($file);
8183
my $stop_log = "$lib_dir/logs/$service.stop";
8184
my $run_log = "$lib_dir/logs/$service.run";
8185
my $cmd = ($env_vars ? "$env_vars " : '')
8186
. "${bin_dir}pt-agent --run-service $service --no-agent-api"
8188
. " >$stop_log 2>&1";
8189
$logger->info("Stopping $service...");
8190
PTDEBUG && _d($cmd);
8192
my $cmd_exit_status = $CHILD_ERROR >> 8;
8193
if ( $cmd_exit_status != 0 ) {
8194
my $err = -f $run_log ? slurp($run_log) : '';
8195
$logger->error("Error stopping $service. Check $stop_log and the "
8196
. "online logs for details. The service may still be running.");
8200
or $logger->warning("Cannot remove $stop_log: $OS_ERROR");
8204
$logger->info("$lib_dir/services does not exist, no services to stop")
8207
$state->{all_services_are_stopped} = 1;
8215
have_required_args(\%args, qw(
8219
my $service = $args{service};
8220
my $lib_dir = $args{lib_dir};
8223
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir}
8226
if ( -d "$lib_dir/services" ) {
8227
my $stop_service_file = "$lib_dir/services/stop-$service";
8228
if ( -f $stop_service_file ) {
8229
my $stop_service = basename($stop_service_file);
8230
my $env_vars = env_vars();
8231
my $stop_log = "$lib_dir/logs/$service.stop";
8232
my $run_log = "$lib_dir/logs/$service.run";
8233
my $cmd = ($env_vars ? "$env_vars " : '')
8234
. "${bin_dir}pt-agent --run-service $stop_service"
8236
. " >$stop_log 2>&1";
8237
$logger->info("Stopping $service...");
8238
PTDEBUG && _d($cmd);
8240
my $cmd_exit_status = $CHILD_ERROR >> 8;
8241
if ( $cmd_exit_status != 0 ) {
8242
my $err = -f $run_log ? slurp($run_log) : '';
8243
$logger->error("Error stopping $service. Check $stop_log, "
8244
. "$run_log, and the online online logs for details. "
8245
. "$service may still be running.");
8249
or $logger->warning("Cannot remove $stop_log: $OS_ERROR");
8253
$logger->warning("$stop_service_file does not exist, cannot stop $service");
8257
$logger->warning("$lib_dir/services does not exist, cannot stop $service");
8266
have_required_args(\%args, qw(
8272
my $pid_file = $args{pid_file}; # for stop_agent()
8273
my $lib_dir = $args{lib_dir};
8274
my $spool_dir = $args{spool_dir};
8275
my $log_file = $args{log_file};
8278
my $api_key = $args{api_key};
8281
print "\nWARNING: All services will stop and all data in $spool_dir/ "
8282
."will be deleted. Are you sure you want to reset pt-agent?\n\n"
8283
. "Press any key to continue, else Ctrl-C to abort.\n";
8284
my $confirmation = <STDIN>;
8287
$logger->info('Stopping pt-agent...');
8288
my $stopped = stop_agent(
8289
pid_file => $pid_file,
8290
lib_dir => $lib_dir,
8293
$logger->warning('Failed to stop pt-agent. Stop the agent, or verify that '
8294
. 'it is no longer running, and try again.');
8298
my $agent = load_local_agent(
8299
lib_dir => $lib_dir,
8303
$logger->warning("$lib_dir/agent does not exist. You will need to re-install "
8304
. "pt-agent after the reset.");
8307
$logger->info("Removing $lib_dir/...");
8309
or $logger->warning("Cannot remove $lib_dir/: $OS_ERROR");
8311
lib_dir => $lib_dir,
8315
my $new_agent = Percona::WebAPI::Resource::Agent->new(
8316
uuid => $agent->uuid,
8319
lib_dir => $lib_dir,
8320
agent => $new_agent,
8324
$logger->info("Removing $spool_dir/...");
8326
or $logger->warning("Cannot remove $spool_dir/: $OS_ERROR");
8328
spool_dir => $spool_dir,
8331
my $config_file = get_config_file();
8332
my $config = -f $config_file ? slurp($config_file) : '';
8333
$logger->info("Resetting $config_file...");
8334
open my $fh, '>', $config_file
8335
or $logger->error("Cannot write to $config_file: $OS_ERROR");
8337
print { $fh } "api-key=$api_key\n";
8339
foreach my $line ( split("\n", $config) ) {
8340
next unless $line =~ m/^\s*(?:user|host|password|socket|defaults-file|port)/;
8341
print { $fh } $line, "\n";
8344
or $logger->warning("Cannot close $config_file: $OS_ERROR");
8346
if ( -f $log_file ) {
8347
$logger->info("Removing $log_file...");
8349
or $logger->warning("Cannot remove $log_file: $OS_ERROR");
8357
my $pid_file = $args{pid_file};
8360
if ( -f $pid_file ) {
8361
PTDEBUG && _d('Reading PID from', $pid_file);
8362
chop($pid = slurp($pid_file));
8365
my $ps_output = `ps ax | grep 'pt-agent --daemonize' | grep -v grep`;
8366
PTDEBUG && _d('Reading PID from ps', $ps_output);
8367
if ( !$ps_output ) {
8368
die Percona::Agent::Exception::PIDNotFound->new(
8369
pid_file => $pid_file,
8372
# Match the first digits, which should be the PID.
8373
($pid) = $ps_output =~ m/(\d+)/;
8377
die Percona::Agent::Exception::NoPID->new(
8378
pid_file => $pid_file,
8379
pid_file_is_empty => -f $pid_file,
8383
my $running = kill 0, $pid;
8385
die Percona::Agent::Exception::PIDNotRunning->new(
8394
my ( $signal ) = @_;
8395
print STDERR "\n# Caught SIG$signal, reloading configuration.\n";
8396
$state->{reload} = 1;
8403
have_required_args(\%args, qw(
8406
my $pid_file = $args{pid_file};
8407
my $lib_dir = $args{lib_dir};
8411
pid_file => $pid_file,
8414
if ( my $e = $EVAL_ERROR ) {
8415
if ( !blessed($e) ) {
8416
$logger->warning("Sorry, an error occured while getting the pt-agent PID: $e");
8418
elsif ( $e->isa('Percona::Agent::Exception::PIDNotFound') ) {
8419
$logger->warning("pt-agent is not running");
8421
elsif ( $e->isa('Percona::Agent::Exception::PIDNotRunning') ) {
8422
$logger->warning("$e. pt-agent may have stopped unexpectedly or crashed.");
8424
else { # unhandled exception
8425
$logger->warning("Sorry, an unknown exception occured while getting "
8426
. "the pt-agent PID: $e");
8430
kill 10, $pid; # SIGUSR1, caught in reload_signal()
8431
$logger->info("Sent reload signal (SIGUSR1) to pt-agent PID $pid");
8443
have_required_args(\%args, qw(
8448
my $o = $args{OptionParser};
8449
my $cxn = $args{Cxn};
8450
my $flags = $args{flags};
8453
my $interactive = $args{interactive};
8455
$logger->quiet(Percona::Agent::Logger::level_number('ERROR'));
8457
my $agent_my_cnf = '/etc/percona/agent/my.cnf';
8458
my $config_file = get_config_file();
8459
my $lib_dir = $o->get('lib');
8464
my $step_fmt = "Step %d of %d: %s: ";
8466
"Verify the user is root",
8467
"Check Perl module dependencies",
8468
"Check for crontab",
8469
"Verify pt-agent is not installed",
8470
"Verify the API key",
8472
"Check if MySQL is a slave",
8473
"Create a MySQL user for the agent",
8474
"Initialize $agent_my_cnf",
8475
"Initialize $config_file",
8479
my $n_steps = scalar @steps;
8480
my $next_step = sub {
8482
my $repeat = $args{repeat};
8483
my $done = $args{done};
8484
# Result of the previous step
8486
if ( $step_result ) {
8487
$result = $step_result;
8488
$step_result = undef;
8490
print "$result\n" if $stepno && !$repeat;
8493
$stepno + ($repeat ? 0 : 1),
8495
$steps[$repeat ? $stepno - 1 : $stepno];
8501
print "INSTALLATION COMPLETE\n";
8506
$stepno + ($repeat ? 0 : 1),
8508
$steps[$repeat ? $stepno - 1 : $stepno];
8509
$stepno++ unless $repeat;
8512
# ########################################################################
8513
# Pre-install checklist
8514
# ########################################################################
8516
# Must be root for --install.
8519
die "You must run pt-agent --install as root.\n";
8522
# Check Perl module dependencies
8524
exit 1 if missing_perl_module_deps();
8526
# Check that LWP is new enough
8527
# https://bugs.launchpad.net/percona-toolkit/+bug/1226721
8528
if ( $LWP::VERSION < '5.813' ) {
8529
die "LWP v5.813 or newer is required; v$LWP::VERSION is installed. Please upgrade LWP on this server and try again.\n"
8534
my $crontab = `which crontab 2>/dev/null`;
8536
die "cron is not installed, or crontab is not in your PATH.\n";
8539
# Verify pt-agent is not installed
8541
my @install_files = ($config_file, "$lib_dir/agent");
8543
foreach my $file (@install_files) {
8544
push @have_files, $file if -f $file;
8546
if ( scalar @have_files ) {
8548
die "It looks like pt-agent is already installed because these files exist:\n"
8549
. join("\n", map { " $_" } @have_files)
8550
. "\nRun pt-agent --uninstall to remove these files. To upgrade pt-agent, "
8551
. "install the new version, run pt-agent --stop, then pt-agent --daemonize "
8552
. "to restart pt-agent with the new version.\n";
8555
# Must have a valid API key.
8557
my $got_api_key = 0;
8558
my $api_key = $o->get('api-key');
8561
if ( $interactive || -t STDIN ) {
8562
while ( !$api_key ) {
8563
print "Enter your API key: ";
8565
chomp($api_key) if $api_key;
8566
if ( !$api_key || length($api_key) < 32 ) {
8567
warn "Invalid API key; it should be at least 32 characters long. Please try again.\n";
8573
die "Please specify your --api-key.\n";
8580
if ( $flags->{offline} ) {
8585
$next_step->(repeat => 1);
8588
($client, $entry_links) = get_api_client(
8589
api_key => $api_key,
8590
interval => sub { return; },
8594
if ( my $e = $EVAL_ERROR ) {
8595
die "Sorry, an error occurred while verifying the API key: $e";
8597
elsif ( !$entry_links ) {
8598
if ( $client->response->code && $client->response->code == 401 ) {
8599
die "Sorry, the API key $api_key is not valid. Please check the API key and try again.\n";
8602
my $err = $client->response->message || 'Unknown error';
8603
die "Sorry, an error occured while verifying the API key: $err\n";
8608
# Must be able to connect to MySQL to create pt_agent user.
8613
if ( $EVAL_ERROR ) {
8615
die "Cannot connect to MySQL: $EVAL_ERROR\n"
8616
. "Please re-run pt-agent --install and specify MySQL connection "
8617
. "options like --user and --host to connect to MySQL as a user "
8618
. "with sufficient privileges to create MySQL users.\n";
8621
# Check if MySQL is a slave
8623
my $slave = $cxn->dbh->selectrow_hashref("SHOW SLAVE STATUS");
8625
$step_result = 'YES, TO MASTER ' . $slave->{master_host} || '?';
8628
$step_result = 'NO';
8631
# ########################################################################
8633
# ########################################################################
8635
# Create a MySQL user for the agent
8637
if ( -f $agent_my_cnf ) {
8638
$step_result = "NO, USE EXISTING $agent_my_cnf";
8641
if ( !$slave ) { # master
8642
create_mysql_user($cxn, $agent_my_cnf);
8645
if ( $flags->{force_dangerous_slave_install} ) {
8646
create_mysql_user($cxn, $agent_my_cnf);
8649
die "Sorry, cannot install the agent because MySQL is a slave "
8650
. "and $agent_my_cnf does not exist. It is not safe to "
8651
. "write to a slave, so a MySQL user for the agent cannot "
8652
. "be created. First install the agent on the master, then "
8653
. "copy $agent_my_cnf from the master to this server. "
8654
. "See SLAVE INSTALL in the docs for more information.\n";
8659
# Save the API key and defaults file in ~/.pt-agent.conf.
8663
data => "api-key=$api_key\ndefaults-file=$agent_my_cnf\n",
8664
file => $config_file,
8667
if ( $EVAL_ERROR ) {
8668
die "Sorry, an error occured while initializing $config_file: "
8672
# Init --lib and --spool. pt-agent would do this itself, but we'll
8673
# do it now in case there are problems.
8676
lib_dir => $lib_dir,
8679
spool_dir => $o->get('spool'),
8682
# 8. Start the agent, don't run it yet. Normally this forks in
8683
# anticipation of run_agent() being called next, but we don't do
8684
# this during install; we run the agent manually later.
8685
if ( $flags->{offline} ) {
8686
$skip++; # Init agent
8687
$skip++; # Run agent
8691
my $running = eval {
8693
api_key => $api_key,
8694
lib_dir => $o->get('lib'),
8697
entry_links => $entry_links,
8698
agent_uuid => $o->get('agent-uuid'),
8703
interval => sub { sleep 2; },
8706
if ( $EVAL_ERROR ) {
8707
if ( $client->response->code && $client->response->code == 403 ) {
8708
die "The maximum number of agents for this organization has been reached; "
8709
. "no more agents can be created. Delete unused agents from "
8710
. "https://cloud.percona.com/agents and try again.\n";
8713
die "Sorry, an error occurred while starting the agent: $EVAL_ERROR";
8717
# 9. Run the agent daemon. If all the previous worked, the agent
8718
# should be able to start without problems. It will get and apply
8719
# the default config, then get and apply any services (probably won't
8722
my $env = env_vars();
8723
my $cmd = "$env $FindBin::Bin/pt-agent --daemonize";
8724
my $ret = system($cmd);
8726
die "Sorry, an error occured while starting pt-agent.\n";
8730
# ########################################################################
8732
# ########################################################################
8733
$next_step->(done => 1);
8735
my $hostname = `hostname`;
8738
if ( $flags->{offline} ) {
8739
print "The agent has been installed, but it was not started. "
8740
. "Run pt-agent --daemonize to start the agent, then go to "
8741
. "https://cloud.percona.com/agents#$hostname to enable services "
8742
. "for the agent.\n";
8745
print "The agent has been installed and started, but it is not "
8746
. "running any services yet. Go to "
8747
. "https://cloud.percona.com/agents#$hostname to enable services "
8748
. "for the agent.\n";
8754
sub create_mysql_user {
8755
my ($cxn, $agent_my_cnf, $user, $pass) = @_;
8757
if ( !$user || !$pass ) {
8759
$pass = pseudo_random_password();
8761
my $sql = "GRANT SUPER,USAGE ON *.* TO 'pt_agent'\@'localhost' "
8762
. "IDENTIFIED BY '$pass'";
8764
$cxn->dbh->do($sql);
8766
if ( $EVAL_ERROR ) {
8767
die "Sorry, an error occurred while creating a MySQL user for the agent: "
8770
$cxn->dbh->disconnect();
8773
# Init $agent_my_cnf
8774
# We could set user= and pass= in ~/.pt-agent.conf, but each new agent
8775
# has a different MySQL password but shares the same default agent
8776
# config, so if we set pass=foo, the next agent would set it to
8777
# pass=bar, etc. Instead, every agent sets/uses
8778
# defaults-file=/etc/percona/agent/my.cnf in the default config, but
8779
# the contents of that file is different for each agent.
8781
if ( !-d '/etc/percona' ) {
8782
_safe_mkdir('/etc/percona');
8784
if ( !-d '/etc/percona/agent' ) {
8785
_safe_mkdir('/etc/percona/agent');
8787
my $my_cnf = "[client]\nuser=$user\npass=$pass\n";
8788
my $dsn = $cxn->dsn;
8790
$my_cnf .= "host=$dsn->{h}\n";
8793
$my_cnf .= "port=$dsn->{P}\n";
8796
$my_cnf .= "socket=$dsn->{S}\n";
8801
file => $agent_my_cnf,
8804
if ( $EVAL_ERROR ) {
8805
die "Sorry, an error occured while initializing $agent_my_cnf: "
8812
sub pseudo_random_password {
8813
my @chars = ("A".."Z", "a".."z", "0".."9");
8815
$string .= $chars[rand @chars] for 1..9;
8819
sub missing_perl_module_deps {
8821
foreach my $pm ( sort keys %deps ) {
8822
my $dep = $deps{$pm};
8823
eval "require $dep->[0]";
8824
if ( $EVAL_ERROR ) {
8825
push @missing_deps, $dep;
8828
if ( @missing_deps ) {
8829
warn "These Perl modules need to be installed:\n\n";
8830
foreach my $dep ( @missing_deps ) {
8831
warn "$dep->[0]\n apt-get install $dep->[1]\n yum install $dep->[2]\n\n";
8834
return scalar @missing_deps;
8837
# ################ #
8838
# --uninstall subs #
8839
# ################ #
8843
have_required_args(\%args, qw(
8847
my $o = $args{OptionParser};
8848
my $cxn = $args{Cxn};
8849
my $flags = $args{flags};
8852
die "You must run pt-agent --uninstall as root.\n";
8855
my $config_file = get_config_file();
8856
my $lib_dir = $o->get('lib');
8857
my $spool_dir = $o->get('spool');
8859
print "Uninstalling pt-agent...\n";
8861
# Stop the agent. This must succeed else it's not safe to remove its
8862
# files and dirs while it's running.
8863
my $stopped = stop_agent(
8864
pid_file => $o->get('pid'),
8865
lib_dir => $o->get('lib'),
8868
$logger->fatal("Failed to stop pt-agent.");
8871
# Agent is stopped so now it's safe to remove all our files and dirs.
8873
if ( -d $lib_dir ) {
8874
push @shell_cmds, "rm -rf $lib_dir";
8876
if ( -d $spool_dir ) {
8877
push @shell_cmds, "rm -rf $spool_dir"
8879
if ( -d "/etc/percona/agent" ) {
8880
push @shell_cmds, "rm -rf /etc/percona/agent/";
8882
if ( -f $config_file ) {
8883
push @shell_cmds, "rm -f $config_file"
8887
if ( scalar @shell_cmds ) {
8888
print "Are you sure you want to run these command "
8889
. "to uninstall pt-agent?\n"
8890
. join("\n", map { " $_" } @shell_cmds) . "\n";
8891
while ( !$rm_files_ok ) {
8892
print "Enter 'yes' to run these commands, or CTRL-C to abort: ";
8893
$rm_files_ok = <STDIN>;
8894
chomp($rm_files_ok) if $rm_files_ok;
8895
if ( $rm_files_ok && $rm_files_ok eq 'yes' ) {
8902
# CTRL-C should prevent us from getting here, but just in case:
8903
return if @shell_cmds && !$rm_files_ok;
8904
foreach my $cmd ( @shell_cmds ) {
8907
if ( $CHILD_ERROR ) {
8908
warn "Command failed: $cmd\n";
8914
warn "ERROR: No pt-agent files or directories found. You can ignore this "
8915
. "error if the agent is not installed, or if it has already been "
8916
. "removed. Else, verify that the values in $config_file are "
8917
. "correct and try again.\n";
8923
if ( $EVAL_ERROR ) {
8925
die "ERROR: Cannot connect to MySQL: $EVAL_ERROR\n"
8926
. "Please re-run pt-agent --uninstall and specify MySQL connection "
8927
. "options like --user and --host to connect to MySQL as a user "
8928
. "with sufficient privileges to drop MySQL users.\n";
8931
my $drop_mysql_user_ok;
8933
$cxn->dbh->selectall_arrayref("SHOW GRANTS FOR 'pt_agent'\@'localhost'");
8935
if ( !$EVAL_ERROR ) {
8936
my $sql = "DROP USER 'pt_agent'\@'localhost'";
8937
print "Are you sure you want to execute this statement "
8938
. "to remove the pt-agent MySQL user?\n$sql\n";
8939
while ( !$drop_mysql_user_ok ) {
8940
print "Enter 'yes' to execute this statment, or CTRL-C to abort: ";
8941
$drop_mysql_user_ok = <STDIN>;
8942
chomp($drop_mysql_user_ok) if $drop_mysql_user_ok;
8943
if ( $drop_mysql_user_ok && $drop_mysql_user_ok eq 'yes' ) {
8947
$drop_mysql_user_ok = 0;
8950
# CTRL-C should prevent us from getting here, but just in case:
8951
return unless $drop_mysql_user_ok;
8953
$cxn->dbh->do($sql);
8955
if ( $EVAL_ERROR ) {
8956
warn "Error dropping the pt-agent MySQL user: $EVAL_ERROR";
8957
$drop_mysql_user_ok = 0;
8961
warn "ERROR: No pt-agent MySQL user found. You can ignore this "
8962
. "error if the agent is not installed, or if it has already been "
8963
. "removed. Else, verify that the values in $config_file are "
8964
. "correct and try again.\n";
8968
if ( $rm_files_ok && $drop_mysql_user_ok ) {
8969
print "pt-agent and all its data has been removed from this server, "
8970
. "but the agent and any data it sent has not been deleted from "
8971
. "Percona Cloud Tools. Go to https://cloud.percona.com/agents "
8972
. "to delete the agent.\n";
8975
warn "Uninstalling pt-agent failed. See previous output for errors "
8976
. "and try again. Contact Percona if you need help.\n";
8982
# ################## #
8983
# Misc and util subs #
8984
# ################## #
8986
sub get_config_file {
8987
my $home_dir = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
8988
my $config_file = "$home_dir/.pt-agent.conf";
8989
return $config_file;
8994
have_required_args(\%args, qw(
8998
my $agent = $args{agent};
8999
my $lib_dir = $args{lib_dir};
9000
my $file = $lib_dir . '/agent';
9001
$logger->debug("Saving Agent to $file");
9003
open my $fh, '>', $file
9004
or die "Error opening $file: $OS_ERROR";
9005
print { $fh } as_json($agent)
9006
or die "Error writing to $file: $OS_ERROR";
9008
or die "Error closing $file: $OS_ERROR";
9010
if ( $EVAL_ERROR ) {
9011
if ( !$state->{save_agent_error}++ ) {
9013
$logger->warning("Cannot save agent to $lib_dir: $EVAL_ERROR. "
9014
. "Configure the agent to use a writeable --lib directory. "
9015
. "This warning will not be printed again.");
9018
delete $state->{save_agent_error};
9024
return unless -f $file;
9025
open my $fh, '<', $file
9026
or die "Error opening $file: $OS_ERROR";
9028
local $INPUT_RECORD_SEPARATOR = undef;
9037
my $data = $args{data};
9038
my $file = $args{file};
9039
die "No file" unless $file;
9040
open my $fh, '>', $file
9041
or die "Error opening $file: $OS_ERROR";
9042
print { $fh } $data;
9048
my $new_logger = shift;
9049
$logger = $new_logger;
9055
my $cxn = $args{Cxn};
9056
my $tries = $args{tries} || 1;
9057
my $interval = $args{interval} || sub { return; };
9059
# This is currently the actual response from GET v.percona.com
9060
my $fake_response = <<EOL;
9062
MySQL;mysql_variable;version_comment,version
9064
DBD::mysql;perl_module_version
9065
Percona::Toolkit;perl_module_version
9066
JSON;perl_module_version
9067
LWP;perl_module_version
9068
IO::Socket::SSL;perl_module_version
9069
DBD::mysql;perl_module_version
9072
my $items = VersionCheck::parse_server_response(
9073
response => $fake_response,
9077
{ name => 'system', id => 0, },
9080
my $have_mysql = -1;
9081
if ( !$cxn->dbh || !$cxn->dbh->ping() ) {
9082
$logger->debug("Connecting to MySQL");
9086
if ( $EVAL_ERROR ) {
9087
$logger->debug("Cannot connect to MySQL: $EVAL_ERROR");
9095
if ( $have_mysql ) {
9096
$logger->debug("Have MySQL connection");
9097
my ($name, $id) = VersionCheck::get_instance_id(
9098
{ dbh => $cxn->dbh, dsn => $cxn->dsn },
9101
{ name => $name, id => $id, dbh => $cxn->dbh, dsn => $cxn->dsn };
9103
# Disconnect MySQL if we connected it.
9104
if ( $have_mysql == 1 ) {
9105
$logger->debug("Disconnecting MySQL");
9107
$cxn->dbh->disconnect();
9109
if ( $EVAL_ERROR ) {
9110
$logger->debug($EVAL_ERROR);
9115
my $versions = VersionCheck::get_versions(
9117
instances => $instances,
9121
foreach my $item ( sort keys %$items ) {
9122
next unless exists $versions->{$item};
9123
if ( ref($versions->{$item}) eq 'HASH' ) {
9124
my $mysql_versions = $versions->{$item};
9125
for my $id ( sort keys %$mysql_versions ) {
9126
$version_for{$item} = $mysql_versions->{$id};
9130
$version_for{$item} = $versions->{$item};
9134
PTDEBUG && _d('Versions:', Dumper(\%version_for));
9135
return \%version_for;
9140
foreach my $var ( qw(
9142
PERCONA_TOOLKIT_TEST_USE_DSN_NAMES
9145
if ( my $val = $ENV{$var} ) {
9146
push @vars, "$var=\"$val\"";
9149
return join(' ', @vars);
9155
# Multiple processes are running at once, all running the same code,
9156
# all trying to init pt-agent's various directories if necessary, so
9157
# race conditions abound. Another process may have created the dir
9158
# between -d checking for it and now, so if mkdir throws a "File exists"
9159
# error and the dir does now exist, then that's ok. Else, it's an error.
9161
mkdir $dir or die $OS_ERROR;
9163
if ( my $e = $EVAL_ERROR ) {
9164
if ( $e =~ /exists/i && -d $dir ) {
9165
PTDEBUG && _d('Another process created', $dir);
9168
die "Cannot mkdir $dir: $e";
9174
sub check_if_mysql_restarted {
9176
have_required_args(\%args, qw(
9179
my $dbh = $args{dbh};
9182
my $uptime = $args{uptime}; # for testing
9183
my $margin = $args{margin} || 5;
9186
my $sql = "SHOW STATUS LIKE 'uptime'";
9188
(undef, $uptime) = $dbh->selectrow_array($sql);
9190
if ( $EVAL_ERROR ) {
9191
$logger->error("$sql: $EVAL_ERROR");
9196
my $now = int(time);
9198
if ( !$state->{last_uptime} || !$state->{last_uptime_check} ) {
9199
$logger->debug("MySQL uptime: $uptime");
9200
delete $state->{mysql_restarted};
9202
elsif ( !$state->{mysql_restarted} ) {
9203
my $elapsed_time = $now - $state->{last_uptime_check};
9204
my $exepected_uptime = $state->{last_uptime} + $elapsed_time;
9205
my $mysql_restarted = $uptime > ($exepected_uptime - $margin) && $uptime < ($exepected_uptime + $margin) ? 0 : 1;
9206
$logger->debug("MySQL uptime check: last=$state->{last_uptime} elapsed=$elapsed_time expected=$exepected_uptime "
9207
. "+/- ${margin}s actual=$uptime");
9208
if ( $mysql_restarted ) {
9209
$logger->warning("MySQL restarted: last=$state->{last_uptime} "
9210
. "elapsed=$elapsed_time expected=$exepected_uptime "
9211
. "+/- ${margin}s actual=$uptime");
9212
$state->{mysql_restarted} = ts(time, 1); # 1=UTC
9213
$state->{need_mysql_version} = 1;
9217
$state->{last_uptime} = $uptime;
9218
$state->{last_uptime_check} = $now;
9223
sub too_many_agents {
9225
have_required_args(\%args, qw(
9228
my $lib_dir = $args{lib_dir};
9229
return unless -d "$lib_dir/pids";
9230
my @pids = glob "$lib_dir/pids/*";
9231
return scalar @pids > 10 ? 1 : 0;
9236
have_required_args(\%args, qw(
9239
my $client = $args{client};
9240
my $ping_link = $client->entry_link . '/ping';
9241
$ping_link =~ s!//ping!/ping!g; # //ping doesn't work
9247
return $EVAL_ERROR ? 0 : 1;
9251
my $_logger = shift;
9252
$logger = $_logger if $_logger;
9258
$state = $_state if $_state;
9262
# Catches signals so we can exit gracefully.
9264
my ( $signal ) = @_;
9266
if ( $exit_on_signals ) {
9267
print STDERR "\n# Caught SIG$signal, exiting.\n";
9270
print STDERR "# Caught SIG$signal. Use 'kill -ABRT $PID' if "
9271
. "the tool does not exit normally in a few seconds.\n";
9275
# ############################################################################
9277
# ############################################################################
9279
if ( !caller ) { exit main(@ARGV); }
9281
1; # Because this is a module as well as a script.
9283
# ############################################################################
9285
# ############################################################################
9290
pt-agent - Agent for Percona Cloud Tools
9294
Usage: pt-agent [OPTIONS]
9296
pt-agent is the client-side agent for Percona Cloud Tools. It is not
9297
a general command line tool like other tools in Percona Toolkit, it is
9298
configured and controlled through the web at https://cloud.percona.com.
9299
Visit https://cloud.percona.com for more information and to sign up.
9303
pt-agent is the client-side agent for Percona Cloud Tools (PCT). It is
9304
controlled and configured through the web app at https://cloud.percona.com.
9305
Visit https://cloud.percona.com for more information and to sign up.
9307
pt-agent, or "the agent", is a single, unique instance of the tool running
9308
on a server. Two agents cannot run on the same server (see L<"--pid">).
9310
The agent is a daemon that runs as root. It should be started with
9311
L<"--daemonize">. It connects periodically to Percona to update
9312
its configuration and services, and it schedules L<"--run-service"> and
9313
L<"--send-data"> instances of itself using cron. Other than L<"INSTALLING">
9314
and starting the agent locally, all control and configuration is done through
9315
the web at https://cloud.percona.com.
9319
pt-agent must be installed and ran as root. It is possible to run as
9320
a non-root user, but this requires a more complicated and manual installation.
9321
Please contact Percona for help if you need to run pt-agent as a non-root user.
9323
Installing the agent as root is very simple:
9325
# pt-agent --install
9327
The agent will prompt you for your Percona Cloud Tools API key. Then it
9328
will verify the API key, create a MySQL user for the agent, and run the agent.
9329
When the install process is complete, go to https://cloud.percona.com to enable
9332
Please contact Percona if you need help installing the agent.
9334
=head2 SLAVE INSTALL
9336
There are two ways to install pt-agent on a slave. The first and best way
9337
is to install the agent on the master so that the L<"MYSQL USER"> is created
9338
on the master and replicates to slaves. This is best because it avoids
9339
writing to the slave. Then create the C</etc/percona/agent/> directory on
9340
the slave and copy in to it C</etc/percona/agent/my.cnf> from the master.
9341
Run L<"--install"> on the slave and pt-agent will automatically detect and
9342
use the MySQL user and password in C</etc/percona/agent/my.cnf>. Repeat the
9343
process for other slaves.
9345
The second way to install pt-agent on a slave is not safe because it writes
9346
directly to the slave: specify L<"--install-options">
9347
C<force_dangerous_slave_install> in addition to L<"--install">. As the
9348
install option name implies, this is dangerous, but it forces pt-agent
9349
to ignore that MySQL is a slave.
9351
=head2 Percona XtraDB Cluster (PXC) INSTALL
9353
Installing pt-agent on Percona XtraDB Cluster (PXC) nodes is the same as
9354
installing it safely on slaves. First install the agent on any node. This
9355
will create the L<"MYSQL USER"> that will replicate to all other nodes.
9356
Then create the C</etc/percona/agent/> directory on another node and copy in
9357
to it C</etc/percona/agent/my.cnf> from the first node where pt-agent was
9358
installed. Run L<"--install"> on the node and pt-agent will automatically
9359
detect and use the MySQL user and password in C</etc/percona/agent/my.cnf>.
9360
Repeat the process for other nodes.
9364
During L<"--install">, pt-agent creates the following MySQL user:
9366
GRANT SUPER, USAGE ON *.* TO 'pt_agent'@'localhost' IDENTIFIED BY 'pass'
9368
C<pass> is a random string. MySQL options for the agent are stored in
9369
C</etc/percona/agent/my.cnf>. The C<SUPER> privilege is required so that
9370
the agent can set global MySQL variables like C<long_query_time>.
9374
pt-agent exists zero if no errors or warnings occurred, else it exits non-zero.
9378
L<"--run-service"> and L<"--send-data"> are mutually exclusive.
9380
L<"--status">, L<"--stop">, and L<"--reset"> are mutually exclusive.
9384
=item --[no]agent-api
9388
Enable the agent API; do not use this option manually. This option is used
9389
internally to allow the agent to stop itself and shutdown quickly.
9395
Existing agent UUID for re-installing an agent.
9401
Your secret Percona Cloud Tools API key.
9405
Prompt for MySQL password.
9407
=item --check-interval
9409
type: time; default: 1m
9411
How often to check for a new configuration and services.
9417
Read this comma-separated list of config files; if specified, this must be the
9418
first option on the command line.
9420
See the L<"--help"> output for a list of default config files.
9424
Daemonize the agent. This causes the agent to fork into the background and
9425
L<"--log"> all output.
9427
Fork to the background and detach from the shell. POSIX operating systems only.
9429
=item --defaults-file
9431
short form: -F; type: string
9433
Only read MySQL options from the given file. You must give an absolute
9436
=item --disk-bytes-free
9438
type: size; default: 100M
9440
Stop all services if the disk has less than this much free space.
9441
This prevents the agent from filling up the disk with service data.
9443
Valid size value suffixes are k, M, G, and T.
9445
=item --disk-pct-free
9447
type: int; default: 5
9449
Stop all services if the disk has less than this percent free space.
9450
This prevents the agent from filling up the disk with service data.
9452
This option works similarly to L<"--disk-bytes-free"> but specifies a
9453
percentage margin of safety instead of a bytes margin of safety.
9454
The agent honors both options, and will not collect any data unless both
9455
margins are satisfied.
9459
Print the agent's help and exit.
9463
short form: -h; type: string; default: localhost
9469
Install pt-agent as root.
9471
=item --install-options
9475
Comma-separated list of L<"--install"> options. Options are:
9481
Do not verify the API key or start the agent.
9483
=item force_dangerous_slave_install
9485
Like the option's name suggests: this forces a dangerous slave install,
9486
so you should not use this option unless you are aware of the potential
9487
consequences. To install the agent on a slave, C</etc/percona/agent/my.cnf>
9488
must exist because it is not safe to create the agent's MySQL user on
9489
a slave. The agent should be installed on the master first, then
9490
C</etc/percona/agent/my.cnf> copied from the master server to the slave
9491
server. Using this option forces the agent to create the agent's MySQL
9492
user on the slave. B<WARNING>: writing to a slave is dangerous and could
9493
cause replication to crash.
9499
Run in interactive mode (disables L<"--[no]log-api">).
9503
type: string; default: /var/lib/pt-agent
9505
Directory in which to save local data. pt-agent is remotely controlled and
9506
configured, but it also saves data locally. These files should not be edited
9511
type: string; default: /var/log/pt-agent.log
9513
Log all output to this file when daemonized.
9519
Log everything through the Percona Cloud Tools API.
9523
short form: -p; type: string
9529
type: string; default: /var/run/pt-agent.pid
9531
Create the given PID file. The file contains the process ID of the script.
9532
The PID file is removed when the script exits. Before starting, the script
9533
checks if the PID file already exists. If it does not, then the script creates
9534
and writes its own PID to it. If it does, then the script checks the following:
9535
if the file contains a PID and a process is running with that PID, then
9536
the script dies; or, if there is no process running with that PID, then the
9537
script overwrites the file with its own PID and starts; else, if the file
9538
contains no PID, then the script dies.
9542
Ping the Percona Cloud Tools API and exit.
9546
short form: -P; type: int
9552
Force pt-agent to reload its configuration immediately.
9556
cumulative: yes; default: 0
9558
Reset pt-agent to a clean post-install state.
9560
B<WARNING>: all L<"--spool"> data will be deleted.
9566
Run a service and spool its data for L<"--send-data">. I<You do not need
9567
to run pt-agent with this option.> The main pt-agent daemon schedules
9568
instances of itself with this option.
9574
Send data for a service to Percona. I<You do not need to run pt-agent with
9575
this option.> The main pt-agent daemon schedules instances of itself with
9582
Set the MySQL variables in this comma-separated list of C<variable=value> pairs.
9584
By default, the agent sets:
9586
=for comment ignore-pt-internal-value
9591
Variables specified on the command line override these defaults. For
9592
example, specifying C<--set-vars wait_timeout=500> overrides the default
9595
The agent prints a warning and continues if a variable cannot be set.
9599
short form: -S; type: string
9605
type: string; default: /var/spool/pt-agent
9607
Directory in which to save service data before sending to Percona.
9608
L<"--run-service"> saves data in this directory, and L<"--send-data">
9609
reads data from this directory. Each service has its own subdirectory,
9610
like C<--spool/query-history> for the Query History service. Data
9611
is removed by L<"--send-data"> after it is successfully sent to Percona.
9615
Print the status of pt-agent.
9619
Stop pt-agent and all services.
9623
Completely remove pt-agent and all its data from the server. This does not
9624
delete the agent from https://cloud.percona.com.
9628
short form: -u; type: string
9630
MySQL user, if not the current system user.
9634
Print the agent's version and exit.
9640
These DSN options are used to create a DSN. Each option is given like
9641
C<option=value>. The options are case-sensitive, so P and p are not the
9642
same option. There cannot be whitespace before or after the C<=> and
9643
if the value contains whitespace it must be quoted. DSN options are
9644
comma-separated. See the L<percona-toolkit> manpage for full details.
9650
dsn: charset; copy: yes
9652
Default character set.
9658
Default database when connecting.
9662
dsn: mysql_read_default_file; copy: yes
9664
Defaults file for connection values.
9668
dsn: host; copy: yes
9674
dsn: password; copy: yes
9680
dsn: port; copy: yes
9686
dsn: mysql_socket; copy: no
9692
dsn: user; copy: yes
9694
MySQL user, if not the current system user.
9700
The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
9701
To enable debugging and capture all output to a file, run the tool like:
9703
PTDEBUG=1 pt-agent ... > FILE 2>&1
9705
Be careful: debugging output is voluminous and can generate several megabytes
9708
=head1 SYSTEM REQUIREMENTS
9714
=item * A Percona Cloud Tools account (https://cloud.percona.com)
9716
=item * Access to https://cloud-api.percona.com
9718
=item * Perl 5.8 or newer
9720
=item * Standard Linux bin tools (grep, awk, stat, etc.)
9724
=item * A Bash shell
9726
=item * Core Perl modules
9728
=item * DBD::mysql Perl module
9730
=item * JSON Perl module
9732
=item * LWP (>= v5.813) Perl module
9734
=item * IO::Socket::SSL Perl module
9740
For a list of known bugs, see L<http://www.percona.com/bugs/pt-agent>.
9742
Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
9743
Include the following information in your bug report:
9747
=item * Complete command-line used to run the tool
9749
=item * Tool L<"--version">
9751
=item * MySQL version of all servers involved
9753
=item * Output from the tool including STDERR
9755
=item * Input files (log/dump/config files, etc.)
9759
If possible, include debugging output by running the tool with C<PTDEBUG>;
9760
see L<"ENVIRONMENT">.
9764
Visit L<http://www.percona.com/software/percona-toolkit/> to download the
9765
latest release of Percona Toolkit.
9771
=head1 ABOUT PERCONA TOOLKIT
9773
This tool is part of Percona Toolkit, a collection of advanced command-line
9774
tools developed by Percona for MySQL support and consulting. Percona Toolkit
9775
was forked from two projects in June, 2011: Maatkit and Aspersa. Those
9776
projects were created by Baron Schwartz and developed primarily by him and
9777
Daniel Nichter, both of whom are employed by Percona. Visit
9778
L<http://www.percona.com/software/> for more software developed by Percona.
9780
=head1 COPYRIGHT, LICENSE, AND WARRANTY
9782
This program is copyright 2013-2014 Percona LLC and/or its affiliates.
9784
THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
9785
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
9786
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
9788
This program is free software; you can redistribute it and/or modify it under
9789
the terms of the GNU General Public License as published by the Free Software
9790
Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
9791
systems, you can issue `man perlgpl' or `man perlartistic' to read these
9794
You should have received a copy of the GNU General Public License along with
9795
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
9796
Place, Suite 330, Boston, MA 02111-1307 USA.