~percona-toolkit-dev/percona-toolkit/pt-table-checksum-fails-on-BINARY-field-in-PK-1381280
» Revision
605
: bin/pt-agent
« back to all changes in this revision
Viewing changes to bin/pt-agent
- browse files at revision 605
- compare with another revision
- download diff
- download tarball
- view history from revision 605
- Committer: Daniel Nichter
- Date: 2014-05-30 01:09:13 UTC
- mfrom: (598.5.6 release-2.2.8)
- Revision ID: daniel@percona.com-20140530010913-4wep0en37aa4vvok
Merge release-2.2.8.
- files added:
- t/pt-table-checksum/plugin.t
- t/pt-table-checksum/samples/plugins
- files removed:
- bin/pt-agent
- lib/Percona/Agent
- lib/Percona/Test
- lib/Percona/Test/Mock
- lib/Percona/WebAPI
- lib/Percona/WebAPI/Exception
- lib/Percona/WebAPI/Resource
- t/lib/Percona/WebAPI
- t/pt-agent
- t/pt-agent/samples
- t/pt-agent/samples/query-history
- files modified:
- Changelog
added
removed
bin/pt-agent
1
#!/usr/bin/env perl
2
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.
6
7
use strict;
8
use warnings FATAL => 'all';
9
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.
14
BEGIN {
15
$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
16
Percona::Toolkit
17
Lmo::Utils
18
Lmo::Meta
19
Lmo::Object
20
Lmo::Types
21
Lmo
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
31
VersionCheck
32
DSNParser
33
OptionParser
34
Cxn
35
Quoter
36
VersionParser
37
Daemon
38
Transformers
39
Safeguards
40
Percona::Agent::Logger
41
));
42
}
43
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
# ###########################################################################
52
{
53
package Percona::Toolkit;
54
55
our $VERSION = '2.2.7';
56
57
use strict;
58
use warnings FATAL => 'all';
59
use English qw(-no_match_vars);
60
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
61
62
use Carp qw(carp cluck);
63
use Data::Dumper qw();
64
65
require Exporter;
66
our @ISA = qw(Exporter);
67
our @EXPORT_OK = qw(
68
have_required_args
69
Dumper
70
_d
71
);
72
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";
80
}
81
}
82
cluck unless $have_required_args; # print backtrace
83
return $have_required_args;
84
}
85
86
sub Dumper {
87
local $Data::Dumper::Indent = 1;
88
local $Data::Dumper::Sortkeys = 1;
89
local $Data::Dumper::Quotekeys = 0;
90
Data::Dumper::Dumper(@_);
91
}
92
93
sub _d {
94
my ($package, undef, $line) = caller 0;
95
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
96
map { defined $_ ? $_ : 'undef' }
97
@_;
98
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
99
}
100
101
1;
102
}
103
# ###########################################################################
104
# End Percona::Toolkit package
105
# ###########################################################################
106
107
# ###########################################################################
108
# Lmo::Utils package
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,
111
# lib/Lmo/Utils.pm
112
# t/lib/Lmo/Utils.t
113
# See https://launchpad.net/percona-toolkit for more information.
114
# ###########################################################################
115
{
116
package Lmo::Utils;
117
118
use strict;
119
use warnings qw( FATAL all );
120
require Exporter;
121
our (@ISA, @EXPORT, @EXPORT_OK);
122
123
BEGIN {
124
@ISA = qw(Exporter);
125
@EXPORT = @EXPORT_OK = qw(
126
_install_coderef
127
_unimport_coderefs
128
_glob_for
129
_stash_for
130
);
131
}
132
133
{
134
no strict 'refs';
135
sub _glob_for {
136
return \*{shift()}
137
}
138
139
sub _stash_for {
140
return \%{ shift() . "::" };
141
}
142
}
143
144
sub _install_coderef {
145
my ($to, $code) = @_;
146
147
return *{ _glob_for $to } = $code;
148
}
149
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};
157
}
158
}
159
}
160
161
1;
162
}
163
# ###########################################################################
164
# End Lmo::Utils package
165
# ###########################################################################
166
167
# ###########################################################################
168
# Lmo::Meta package
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,
171
# lib/Lmo/Meta.pm
172
# t/lib/Lmo/Meta.t
173
# See https://launchpad.net/percona-toolkit for more information.
174
# ###########################################################################
175
{
176
package Lmo::Meta;
177
use strict;
178
use warnings qw( FATAL all );
179
180
my %metadata_for;
181
182
sub new {
183
my $class = shift;
184
return bless { @_ }, $class
185
}
186
187
sub metadata_for {
188
my $self = shift;
189
my ($class) = @_;
190
191
return $metadata_for{$class} ||= {};
192
}
193
194
sub class { shift->{class} }
195
196
sub attributes {
197
my $self = shift;
198
return keys %{$self->metadata_for($self->class)}
199
}
200
201
sub attributes_for_new {
202
my $self = shift;
203
my @attributes;
204
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};
210
}
211
else {
212
push @attributes, $attr;
213
}
214
}
215
return @attributes;
216
}
217
218
1;
219
}
220
# ###########################################################################
221
# End Lmo::Meta package
222
# ###########################################################################
223
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,
228
# lib/Lmo/Object.pm
229
# t/lib/Lmo/Object.t
230
# See https://launchpad.net/percona-toolkit for more information.
231
# ###########################################################################
232
{
233
package Lmo::Object;
234
235
use strict;
236
use warnings qw( FATAL all );
237
238
use Carp ();
239
use Scalar::Util qw(blessed);
240
241
use Lmo::Meta;
242
use Lmo::Utils qw(_glob_for);
243
244
sub new {
245
my $class = shift;
246
my $args = $class->BUILDARGS(@_);
247
248
my $class_metadata = Lmo::Meta->metadata_for($class);
249
250
my @args_to_delete;
251
while ( my ($attr, $meta) = each %$class_metadata ) {
252
next unless exists $meta->{init_arg};
253
my $init_arg = $meta->{init_arg};
254
255
if ( defined $init_arg ) {
256
$args->{$attr} = delete $args->{$init_arg};
257
}
258
else {
259
push @args_to_delete, $attr;
260
}
261
}
262
263
delete $args->{$_} for @args_to_delete;
264
265
for my $attribute ( keys %$args ) {
266
if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
267
$args->{$attribute} = $coerce->($args->{$attribute});
268
}
269
if ( my $isa_check = $class_metadata->{$attribute}{isa} ) {
270
my ($check_name, $check_sub) = @$isa_check;
271
$check_sub->($args->{$attribute});
272
}
273
}
274
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}
279
}
280
281
my $self = bless $args, $class;
282
283
my @build_subs;
284
my $linearized_isa = mro::get_linear_isa($class);
285
286
for my $isa_class ( @$linearized_isa ) {
287
unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE};
288
}
289
my @args = %$args;
290
for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
291
$sub->( $self, @args);
292
}
293
return $self;
294
}
295
296
sub BUILDARGS {
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
302
}
303
else {
304
return { @_ };
305
}
306
}
307
308
sub meta {
309
my $class = shift;
310
$class = Scalar::Util::blessed($class) || $class;
311
return Lmo::Meta->new(class => $class);
312
}
313
314
1;
315
}
316
# ###########################################################################
317
# End Lmo::Object package
318
# ###########################################################################
319
320
# ###########################################################################
321
# Lmo::Types package
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,
324
# lib/Lmo/Types.pm
325
# t/lib/Lmo/Types.t
326
# See https://launchpad.net/percona-toolkit for more information.
327
# ###########################################################################
328
{
329
package Lmo::Types;
330
331
use strict;
332
use warnings qw( FATAL all );
333
334
use Carp ();
335
use Scalar::Util qw(looks_like_number blessed);
336
337
338
our %TYPES = (
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 },
345
346
map {
347
my $type = /R/ ? $_ : uc $_;
348
$_ . "Ref" => sub { ref $_[0] eq $type }
349
} qw(Array Code Hash Regexp Glob Scalar)
350
);
351
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)))
359
)
360
|| Carp::confess(
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') )
364
}
365
366
sub _nested_constraints {
367
my ($attribute, $aggregate_type, $type) = @_;
368
369
my $inner_types;
370
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
371
$inner_types = _nested_constraints($1, $2);
372
}
373
else {
374
$inner_types = $TYPES{$type};
375
}
376
377
if ( $aggregate_type eq 'ArrayRef' ) {
378
return sub {
379
my ($val) = @_;
380
return unless ref($val) eq ref([]);
381
382
if ($inner_types) {
383
for my $value ( @{$val} ) {
384
return unless $inner_types->($value)
385
}
386
}
387
else {
388
for my $value ( @{$val} ) {
389
return unless $value && ($value eq $type
390
|| (Scalar::Util::blessed($value) && $value->isa($type)));
391
}
392
}
393
return 1;
394
};
395
}
396
elsif ( $aggregate_type eq 'Maybe' ) {
397
return sub {
398
my ($value) = @_;
399
return 1 if ! defined($value);
400
if ($inner_types) {
401
return unless $inner_types->($value)
402
}
403
else {
404
return unless $value eq $type
405
|| (Scalar::Util::blessed($value) && $value->isa($type));
406
}
407
return 1;
408
}
409
}
410
else {
411
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
412
}
413
}
414
415
1;
416
}
417
# ###########################################################################
418
# End Lmo::Types package
419
# ###########################################################################
420
421
# ###########################################################################
422
# Lmo package
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,
425
# lib/Lmo.pm
426
# t/lib/Lmo.t
427
# See https://launchpad.net/percona-toolkit for more information.
428
# ###########################################################################
429
{
430
BEGIN {
431
$INC{"Lmo.pm"} = __FILE__;
432
package Lmo;
433
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
434
435
436
use strict;
437
use warnings qw( FATAL all );
438
439
use Carp ();
440
use Scalar::Util qw(looks_like_number blessed);
441
442
use Lmo::Meta;
443
use Lmo::Object;
444
use Lmo::Types;
445
446
use Lmo::Utils;
447
448
my %export_for;
449
sub import {
450
warnings->import(qw(FATAL all));
451
strict->import();
452
453
my $caller = scalar caller(); # Caller's package
454
my %exports = (
455
extends => \&extends,
456
has => \&has,
457
with => \&with,
458
override => \&override,
459
confess => \&Carp::confess,
460
);
461
462
$export_for{$caller} = \%exports;
463
464
for my $keyword ( keys %exports ) {
465
_install_coderef "${caller}::$keyword" => $exports{$keyword};
466
}
467
468
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
469
@_ = "Lmo::Object";
470
goto *{ _glob_for "${caller}::extends" }{CODE};
471
}
472
}
473
474
sub extends {
475
my $caller = scalar caller();
476
for my $class ( @_ ) {
477
_load_module($class);
478
}
479
_set_package_isa($caller, @_);
480
_set_inherited_metadata($caller);
481
}
482
483
sub _load_module {
484
my ($class) = @_;
485
486
(my $file = $class) =~ s{::|'}{/}g;
487
$file .= '.pm';
488
{ local $@; eval { require "$file" } } # or warn $@;
489
return;
490
}
491
492
sub with {
493
my $package = scalar caller();
494
require Role::Tiny;
495
for my $role ( @_ ) {
496
_load_module($role);
497
_role_attribute_metadata($package, $role);
498
}
499
Role::Tiny->apply_roles_to_package($package, @_);
500
}
501
502
sub _role_attribute_metadata {
503
my ($package, $role) = @_;
504
505
my $package_meta = Lmo::Meta->metadata_for($package);
506
my $role_meta = Lmo::Meta->metadata_for($role);
507
508
%$package_meta = (%$role_meta, %$package_meta);
509
}
510
511
sub has {
512
my $names = shift;
513
my $caller = scalar caller();
514
515
my $class_metadata = Lmo::Meta->metadata_for($caller);
516
517
for my $attribute ( ref $names ? @$names : $names ) {
518
my %args = @_;
519
my $method = ($args{is} || '') eq 'ro'
520
? sub {
521
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
522
if $#_;
523
return $_[0]{$attribute};
524
}
525
: sub {
526
return $#_
527
? $_[0]{$attribute} = $_[1]
528
: $_[0]{$attribute};
529
};
530
531
$class_metadata->{$attribute} = ();
532
533
if ( my $type_check = $args{isa} ) {
534
my $check_name = $type_check;
535
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);
538
}
539
540
my $check_sub = sub {
541
my ($new_val) = @_;
542
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
543
};
544
545
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
546
my $orig_method = $method;
547
$method = sub {
548
$check_sub->($_[1]) if $#_;
549
goto &$orig_method;
550
};
551
}
552
553
if ( my $builder = $args{builder} ) {
554
my $original_method = $method;
555
$method = sub {
556
$#_
557
? goto &$original_method
558
: ! exists $_[0]{$attribute}
559
? $_[0]{$attribute} = $_[0]->$builder
560
: goto &$original_method
561
};
562
}
563
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;
568
$method = sub {
569
$#_
570
? goto &$original_method
571
: ! exists $_[0]{$attribute}
572
? $_[0]{$attribute} = $_[0]->$code
573
: goto &$original_method
574
};
575
}
576
577
if ( my $role = $args{does} ) {
578
my $original_method = $method;
579
$method = sub {
580
if ( $#_ ) {
581
Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
582
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
583
}
584
goto &$original_method
585
};
586
}
587
588
if ( my $coercion = $args{coerce} ) {
589
$class_metadata->{$attribute}{coerce} = $coercion;
590
my $original_method = $method;
591
$method = sub {
592
if ( $#_ ) {
593
return $original_method->($_[0], $coercion->($_[1]))
594
}
595
goto &$original_method;
596
}
597
}
598
599
_install_coderef "${caller}::$attribute" => $method;
600
601
if ( $args{required} ) {
602
$class_metadata->{$attribute}{required} = 1;
603
}
604
605
if ($args{clearer}) {
606
_install_coderef "${caller}::$args{clearer}"
607
=> sub { delete shift->{$attribute} }
608
}
609
610
if ($args{predicate}) {
611
_install_coderef "${caller}::$args{predicate}"
612
=> sub { exists shift->{$attribute} }
613
}
614
615
if ($args{handles}) {
616
_has_handles($caller, $attribute, \%args);
617
}
618
619
if (exists $args{init_arg}) {
620
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
621
}
622
}
623
}
624
625
sub _has_handles {
626
my ($caller, $attribute, $args) = @_;
627
my $handles = $args->{handles};
628
629
my $ref = ref $handles;
630
my $kv;
631
if ( $ref eq ref [] ) {
632
$kv = { map { $_,$_ } @{$handles} };
633
}
634
elsif ( $ref eq ref {} ) {
635
$kv = $handles;
636
}
637
elsif ( $ref eq ref qr// ) {
638
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
639
unless $args->{isa};
640
my $target_class = $args->{isa};
641
$kv = {
642
map { $_, $_ }
643
grep { $_ =~ $handles }
644
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
645
grep { !$export_for{$target_class}->{$_} }
646
keys %{ _stash_for $target_class }
647
};
648
}
649
else {
650
Carp::confess("handles for $ref not yet implemented");
651
}
652
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")
656
if defined &$name;
657
658
my ($target, @curried_args) = ref($target) ? @$target : $target;
659
*$name = sub {
660
my $self = shift;
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, @_);
667
}
668
}
669
}
670
671
sub _set_package_isa {
672
my ($package, @new_isa) = @_;
673
my $package_isa = \*{ _glob_for "${package}::ISA" };
674
@{*$package_isa} = @new_isa;
675
}
676
677
sub _set_inherited_metadata {
678
my $class = shift;
679
my $class_metadata = Lmo::Meta->metadata_for($class);
680
my $linearized_isa = mro::get_linear_isa($class);
681
my %new_metadata;
682
683
for my $isa_class (reverse @$linearized_isa) {
684
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
685
%new_metadata = (
686
%new_metadata,
687
%$isa_metadata,
688
);
689
}
690
%$class_metadata = %new_metadata;
691
}
692
693
sub unimport {
694
my $caller = scalar caller();
695
my $target = caller;
696
_unimport_coderefs($target, keys %{$export_for{$caller}});
697
}
698
699
sub Dumper {
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;
705
706
Data::Dumper::Dumper(@_)
707
}
708
709
BEGIN {
710
if ($] >= 5.010) {
711
{ local $@; require mro; }
712
}
713
else {
714
local $@;
715
eval {
716
require MRO::Compat;
717
} or do {
718
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
719
no strict 'refs';
720
721
my $classname = shift;
722
723
my @lin = ($classname);
724
my %stored;
725
foreach my $parent (@{"$classname\::ISA"}) {
726
my $plin = mro::get_linear_isa_dfs($parent);
727
foreach (@$plin) {
728
next if exists $stored{$_};
729
push(@lin, $_);
730
$stored{$_} = 1;
731
}
732
}
733
return \@lin;
734
};
735
}
736
}
737
}
738
739
sub override {
740
my ($methods, $code) = @_;
741
my $caller = scalar caller;
742
743
for my $method ( ref($methods) ? @$methods : $methods ) {
744
my $full_method = "${caller}::${method}";
745
*{_glob_for $full_method} = $code;
746
}
747
}
748
749
}
750
1;
751
}
752
# ###########################################################################
753
# End Lmo package
754
# ###########################################################################
755
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
# ###########################################################################
764
{
765
package Percona::WebAPI::Representation;
766
767
eval {
768
require JSON;
769
};
770
771
require Exporter;
772
our @ISA = qw(Exporter);
773
our @EXPORT_OK = qw(
774
as_hashref
775
as_json
776
as_config
777
);
778
779
sub as_hashref {
780
my ($resource, %args) = @_;
781
782
my $as_hashref = { %$resource };
783
784
if ( !defined $args{with_links} || !$args{with_links} ) {
785
delete $as_hashref->{links};
786
}
787
788
return $as_hashref;
789
}
790
791
sub as_json {
792
my ($resource, %args) = @_;
793
794
my $json = $args{json} || JSON->new;
795
$json->allow_blessed([]);
796
$json->convert_blessed([]);
797
798
my $text = $json->encode(
799
ref $resource eq 'ARRAY' ? $resource : as_hashref($resource, %args)
800
);
801
if ( $args{json} && $text ) { # for testing
802
chomp($text);
803
$text .= "\n";
804
}
805
return $text;
806
}
807
808
sub as_config {
809
my $resource = shift;
810
if ( !$resource->isa('Percona::WebAPI::Resource::Config') ) {
811
die "Only Config resources can be represented as config.\n";
812
}
813
my $as_hashref = as_hashref($resource);
814
my $options = $as_hashref->{options};
815
my $config = join("\n",
816
map { defined $options->{$_} ? "$_=$options->{$_}" : "$_" }
817
sort keys %$options
818
) . "\n";
819
return $config;
820
}
821
822
1;
823
}
824
# ###########################################################################
825
# End Percona::WebAPI::Representation package
826
# ###########################################################################
827
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
# ###########################################################################
836
{
837
package Percona::WebAPI::Client;
838
839
our $VERSION = '0.01';
840
841
use strict;
842
use warnings FATAL => 'all';
843
use English qw(-no_match_vars);
844
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
845
846
eval {
847
require LWP;
848
require JSON;
849
};
850
851
use Scalar::Util qw(blessed);
852
853
use Lmo;
854
use Percona::Toolkit;
855
use Percona::WebAPI::Representation;
856
use Percona::WebAPI::Exception::Request;
857
use Percona::WebAPI::Exception::Resource;
858
859
Percona::WebAPI::Representation->import(qw(as_json));
860
Percona::Toolkit->import(qw(_d Dumper have_required_args));
861
862
has 'api_key' => (
863
is => 'ro',
864
isa => 'Str',
865
required => 1,
866
);
867
868
has 'entry_link' => (
869
is => 'rw',
870
isa => 'Str',
871
required => 0,
872
default => sub { return 'https://cloud-api.percona.com' },
873
);
874
875
has 'ua' => (
876
is => 'rw',
877
isa => 'Object',
878
lazy => 1,
879
required => 0,
880
builder => '_build_ua',
881
);
882
883
has 'response' => (
884
is => 'rw',
885
isa => 'Object',
886
required => 0,
887
default => undef,
888
);
889
890
sub _build_ua {
891
my $self = shift;
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);
896
return $ua;
897
}
898
899
sub get {
900
my ($self, %args) = @_;
901
902
have_required_args(\%args, qw(
903
link
904
)) or die;
905
my ($link) = $args{link};
906
907
eval {
908
$self->_request(
909
method => 'GET',
910
link => $link,
911
);
912
};
913
if ( my $e = $EVAL_ERROR ) {
914
if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
915
die $e;
916
}
917
else {
918
die "Unknown error: $e";
919
}
920
}
921
922
my $resource = eval {
923
JSON::decode_json($self->response->content);
924
};
925
if ( $EVAL_ERROR ) {
926
warn sprintf "Error decoding resource: %s: %s",
927
$self->response->content,
928
$EVAL_ERROR;
929
return;
930
}
931
932
my $resource_objects;
933
if ( my $type = $self->response->headers->{'x-percona-resource-type'} ) {
934
eval {
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;
942
}
943
}
944
else {
945
PTDEBUG && _d('Got a', $type, 'resource', Dumper($resource));
946
$resource_objects = $type->new(%$resource);
947
}
948
};
949
if ( my $e = $EVAL_ERROR ) {
950
die Percona::WebAPI::Exception::Resource->new(
951
type => $type,
952
link => $link,
953
data => (ref $resource eq 'ARRAY' ? $resource : [ $resource ]),
954
error => $e,
955
);
956
}
957
}
958
elsif ( exists $resource->{links} ) {
959
$resource_objects = $resource->{links};
960
}
961
elsif ( exists $resource->{pong} ) {
962
PTDEBUG && _d("Ping pong!");
963
}
964
else {
965
warn "Did not get X-Percona-Resource-Type or links from $link\n";
966
}
967
968
return $resource_objects;
969
}
970
971
sub post {
972
my $self = shift;
973
$self->_set(
974
@_,
975
method => 'POST',
976
);
977
return $self->response->header('Location');
978
}
979
980
sub put {
981
my $self = shift;
982
$self->_set(
983
@_,
984
method => 'PUT',
985
);
986
return $self->response->header('Location');
987
}
988
989
sub delete {
990
my ($self, %args) = @_;
991
have_required_args(\%args, qw(
992
link
993
)) or die;
994
my ($link) = $args{link};
995
996
eval {
997
$self->_request(
998
method => 'DELETE',
999
link => $link,
1000
headers => { 'Content-Length' => 0 },
1001
);
1002
};
1003
if ( my $e = $EVAL_ERROR ) {
1004
if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
1005
die $e;
1006
}
1007
else {
1008
die "Unknown error: $e";
1009
}
1010
}
1011
1012
return;
1013
}
1014
1015
sub _set {
1016
my ($self, %args) = @_;
1017
have_required_args(\%args, qw(
1018
method
1019
resources
1020
link
1021
)) or die;
1022
my $method = $args{method};
1023
my $res = $args{resources};
1024
my $link = $args{link};
1025
1026
my $headers = $args{headers};
1027
1028
my $content = '';
1029
if ( ref($res) eq 'ARRAY' ) {
1030
PTDEBUG && _d('List of resources');
1031
$content = '[' . join(",\n", map { as_json($_) } @$res) . ']';
1032
}
1033
elsif ( ref($res) ) {
1034
PTDEBUG && _d('Resource object');
1035
$content = as_json($res);
1036
}
1037
elsif ( $res !~ m/\n/ && -f $res ) {
1038
PTDEBUG && _d('List of resources in file', $res);
1039
$content = '[';
1040
my $data = do {
1041
local $INPUT_RECORD_SEPARATOR = undef;
1042
open my $fh, '<', $res
1043
or die "Error opening $res: $OS_ERROR";
1044
<$fh>;
1045
};
1046
$data =~ s/,?\s*$/]/;
1047
$content .= $data;
1048
}
1049
else {
1050
PTDEBUG && _d('Resource text');
1051
$content = $res;
1052
}
1053
1054
eval {
1055
$self->_request(
1056
method => $method,
1057
link => $link,
1058
content => $content,
1059
headers => $headers,
1060
);
1061
};
1062
if ( my $e = $EVAL_ERROR ) {
1063
if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
1064
die $e;
1065
}
1066
else {
1067
die "Unknown error: $e";
1068
}
1069
}
1070
1071
return;
1072
}
1073
1074
sub _request {
1075
my ($self, %args) = @_;
1076
1077
have_required_args(\%args, qw(
1078
method
1079
link
1080
)) or die;
1081
my $method = $args{method};
1082
my $link = $args{link};
1083
1084
my $content = $args{content};
1085
my $headers = $args{headers};
1086
1087
my $req = HTTP::Request->new($method => $link);
1088
if ( $content ) {
1089
$req->content($content);
1090
}
1091
if ( $headers ) {
1092
map { $req->header($_ => $headers->{$_}) } keys %$headers;
1093
}
1094
PTDEBUG && _d('Request', $method, $link, Dumper($req));
1095
1096
my $response = $self->ua->request($req);
1097
PTDEBUG && _d('Response', Dumper($response));
1098
1099
$self->response($response);
1100
1101
if ( !($response->code >= 200 && $response->code < 400) ) {
1102
die Percona::WebAPI::Exception::Request->new(
1103
method => $method,
1104
url => $link,
1105
content => $content,
1106
status => $response->code,
1107
error => "Failed to $method $link",
1108
);
1109
}
1110
1111
return;
1112
}
1113
1114
no Lmo;
1115
1;
1116
}
1117
# ###########################################################################
1118
# End Percona::WebAPI::Client package
1119
# ###########################################################################
1120
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
# ###########################################################################
1129
{
1130
package Percona::WebAPI::Exception::Request;
1131
1132
use Lmo;
1133
use overload '""' => \&as_string;
1134
1135
has 'method' => (
1136
is => 'ro',
1137
isa => 'Str',
1138
required => 1,
1139
);
1140
1141
has 'url' => (
1142
is => 'ro',
1143
isa => 'Str',
1144
required => 1,
1145
);
1146
1147
has 'content' => (
1148
is => 'ro',
1149
isa => 'Maybe[Str]',
1150
required => 0,
1151
);
1152
1153
has 'status' => (
1154
is => 'ro',
1155
isa => 'Int',
1156
required => 1,
1157
);
1158
1159
has 'error' => (
1160
is => 'ro',
1161
isa => 'Str',
1162
required => 1,
1163
);
1164
1165
sub as_string {
1166
my $self = shift;
1167
chomp(my $error = $self->error);
1168
$error =~ s/\n/ /g;
1169
return sprintf "%s\nRequest: %s %s %s\nStatus: %d\n",
1170
$error, $self->method, $self->url, $self->content || '', $self->status;
1171
}
1172
1173
no Lmo;
1174
1;
1175
}
1176
# ###########################################################################
1177
# End Percona::WebAPI::Exception::Request package
1178
# ###########################################################################
1179
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
# ###########################################################################
1188
{
1189
package Percona::WebAPI::Exception::Resource;
1190
1191
use Lmo;
1192
use overload '""' => \&as_string;
1193
use Data::Dumper;
1194
1195
has 'type' => (
1196
is => 'ro',
1197
isa => 'Str',
1198
required => 1,
1199
);
1200
1201
has 'link' => (
1202
is => 'ro',
1203
isa => 'Str',
1204
required => 1,
1205
);
1206
1207
has 'data' => (
1208
is => 'ro',
1209
isa => 'ArrayRef',
1210
required => 1,
1211
);
1212
1213
has 'error' => (
1214
is => 'ro',
1215
isa => 'Str',
1216
required => 1,
1217
);
1218
1219
sub as_string {
1220
my $self = shift;
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;
1227
}
1228
1229
no Lmo;
1230
1;
1231
}
1232
# ###########################################################################
1233
# End Percona::WebAPI::Exception::Resource package
1234
# ###########################################################################
1235
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
# ###########################################################################
1244
{
1245
package Percona::WebAPI::Resource::Agent;
1246
1247
use Lmo;
1248
1249
has 'uuid' => (
1250
is => 'ro',
1251
isa => 'Str',
1252
required => 0,
1253
);
1254
1255
has 'username' => (
1256
is => 'rw',
1257
isa => 'Str',
1258
required => 0,
1259
default => sub { return $ENV{USER} || $ENV{LOGNAME} },
1260
);
1261
1262
has 'hostname' => (
1263
is => 'rw',
1264
isa => 'Str',
1265
required => 0,
1266
default => sub {
1267
chomp(my $hostname = `hostname`);
1268
return $hostname;
1269
},
1270
);
1271
1272
has 'alias' => (
1273
is => 'rw',
1274
isa => 'Str',
1275
required => 0,
1276
);
1277
1278
has 'versions' => (
1279
is => 'rw',
1280
isa => 'Maybe[HashRef]',
1281
required => 0,
1282
);
1283
1284
has 'links' => (
1285
is => 'rw',
1286
isa => 'Maybe[HashRef]',
1287
required => 0,
1288
default => sub { return {} },
1289
);
1290
1291
sub name {
1292
my ($self) = @_;
1293
return $self->alias || $self->hostname || $self->uuid || 'Unknown';
1294
}
1295
1296
no Lmo;
1297
1;
1298
}
1299
# ###########################################################################
1300
# End Percona::WebAPI::Resource::Agent package
1301
# ###########################################################################
1302
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
# ###########################################################################
1311
{
1312
package Percona::WebAPI::Resource::Config;
1313
1314
use Lmo;
1315
1316
has 'ts' => (
1317
is => 'ro',
1318
isa => 'Int',
1319
required => 1,
1320
);
1321
1322
has 'name' => (
1323
is => 'ro',
1324
isa => 'Str',
1325
required => 1,
1326
);
1327
1328
has 'options' => (
1329
is => 'ro',
1330
isa => 'HashRef',
1331
required => 1,
1332
);
1333
1334
has 'links' => (
1335
is => 'rw',
1336
isa => 'Maybe[HashRef]',
1337
required => 0,
1338
default => sub { return {} },
1339
);
1340
1341
no Lmo;
1342
1;
1343
}
1344
# ###########################################################################
1345
# End Percona::WebAPI::Resource::Config package
1346
# ###########################################################################
1347
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
# ###########################################################################
1356
{
1357
package Percona::WebAPI::Resource::Service;
1358
1359
use Lmo;
1360
1361
has 'ts' => (
1362
is => 'ro',
1363
isa => 'Int',
1364
required => 1,
1365
);
1366
1367
has 'name' => (
1368
is => 'ro',
1369
isa => 'Str',
1370
required => 1,
1371
);
1372
1373
has 'tasks' => (
1374
is => 'ro',
1375
isa => 'ArrayRef[Percona::WebAPI::Resource::Task]',
1376
required => 1,
1377
);
1378
1379
has 'run_schedule' => (
1380
is => 'ro',
1381
isa => 'Str',
1382
required => 0,
1383
);
1384
1385
has 'spool_schedule' => (
1386
is => 'ro',
1387
isa => 'Str',
1388
required => 0,
1389
);
1390
1391
has 'meta' => (
1392
is => 'ro',
1393
isa => 'Bool',
1394
required => 0,
1395
default => sub { return 0 },
1396
);
1397
1398
has 'run_once' => (
1399
is => 'ro',
1400
isa => 'Bool',
1401
required => 0,
1402
default => sub { return 0 },
1403
);
1404
1405
has 'links' => (
1406
is => 'rw',
1407
isa => 'Maybe[HashRef]',
1408
required => 0,
1409
default => sub { return {} },
1410
);
1411
1412
sub BUILDARGS {
1413
my ($class, %args) = @_;
1414
if ( ref $args{tasks} eq 'ARRAY' ) {
1415
my @tasks;
1416
foreach my $run_hashref ( @{$args{tasks}} ) {
1417
my $task = Percona::WebAPI::Resource::Task->new(%$run_hashref);
1418
push @tasks, $task;
1419
}
1420
$args{tasks} = \@tasks;
1421
}
1422
return $class->SUPER::BUILDARGS(%args);
1423
}
1424
1425
no Lmo;
1426
1;
1427
}
1428
# ###########################################################################
1429
# End Percona::WebAPI::Resource::Service package
1430
# ###########################################################################
1431
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
# ###########################################################################
1440
{
1441
package Percona::WebAPI::Resource::Task;
1442
1443
use Lmo;
1444
1445
has 'name' => (
1446
is => 'ro',
1447
isa => 'Str',
1448
required => 1,
1449
);
1450
1451
has 'number' => (
1452
is => 'ro',
1453
isa => 'Int',
1454
required => 1,
1455
);
1456
1457
has 'program' => (
1458
is => 'ro',
1459
isa => 'Maybe[Str]',
1460
required => 0,
1461
);
1462
1463
has 'query' => (
1464
is => 'ro',
1465
isa => 'Maybe[Str]',
1466
required => 0,
1467
);
1468
1469
has 'output' => (
1470
is => 'ro',
1471
isa => 'Maybe[Str]',
1472
required => 0,
1473
);
1474
1475
sub TO_JSON { return { %{ shift() } }; }
1476
1477
no Lmo;
1478
1;
1479
}
1480
# ###########################################################################
1481
# End Percona::WebAPI::Resource::Task package
1482
# ###########################################################################
1483
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
# ###########################################################################
1492
{
1493
package Percona::WebAPI::Resource::LogEntry;
1494
1495
use Lmo;
1496
1497
has 'pid' => (
1498
is => 'ro',
1499
isa => 'Int',
1500
required => 1,
1501
);
1502
1503
has 'service' => (
1504
is => 'ro',
1505
isa => 'Str',
1506
required => 0,
1507
);
1508
1509
has 'data_ts' => (
1510
is => 'ro',
1511
isa => 'Int',
1512
required => 0,
1513
);
1514
1515
has 'entry_ts' => (
1516
is => 'ro',
1517
isa => 'Str',
1518
required => 1,
1519
);
1520
1521
has 'log_level' => (
1522
is => 'ro',
1523
isa => 'Int',
1524
required => 1,
1525
);
1526
1527
has 'message' => (
1528
is => 'ro',
1529
isa => 'Str',
1530
required => 1,
1531
);
1532
1533
no Lmo;
1534
1;
1535
}
1536
# ###########################################################################
1537
# End Percona::WebAPI::Resource::LogEntry package
1538
# ###########################################################################
1539
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
# ###########################################################################
1548
{
1549
package VersionCheck;
1550
1551
1552
use strict;
1553
use warnings FATAL => 'all';
1554
use English qw(-no_match_vars);
1555
1556
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1557
1558
use Data::Dumper;
1559
local $Data::Dumper::Indent = 1;
1560
local $Data::Dumper::Sortkeys = 1;
1561
local $Data::Dumper::Quotekeys = 0;
1562
1563
use Digest::MD5 qw(md5_hex);
1564
use Sys::Hostname qw(hostname);
1565
use File::Basename qw();
1566
use File::Spec;
1567
use FindBin qw();
1568
1569
eval {
1570
require Percona::Toolkit;
1571
require HTTP::Micro;
1572
};
1573
1574
{
1575
my $file = 'percona-version-check';
1576
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
1577
my @vc_dirs = (
1578
'/etc/percona',
1579
'/etc/percona-toolkit',
1580
'/tmp',
1581
"$home",
1582
);
1583
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;
1589
}
1590
}
1591
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
1592
return $file; # in the CWD
1593
}
1594
}
1595
1596
sub version_check_time_limit {
1597
return 60 * 60 * 24; # one day
1598
}
1599
1600
1601
sub version_check {
1602
my (%args) = @_;
1603
1604
my $instances = $args{instances} || [];
1605
my $instances_to_check;
1606
1607
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
1608
if ( !$args{force} ) {
1609
if ( $FindBin::Bin
1610
&& (-d "$FindBin::Bin/../.bzr" || -d "$FindBin::Bin/../../.bzr") ) {
1611
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
1612
return;
1613
}
1614
}
1615
1616
eval {
1617
foreach my $instance ( @$instances ) {
1618
my ($name, $id) = get_instance_id($instance);
1619
$instance->{name} = $name;
1620
$instance->{id} = $id;
1621
}
1622
1623
push @$instances, { name => 'system', id => 0 };
1624
1625
$instances_to_check = get_instances_to_check(
1626
instances => $instances,
1627
vc_file => $args{vc_file}, # testing
1628
now => $args{now}, # testing
1629
);
1630
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
1631
return unless @$instances_to_check;
1632
1633
my $protocol = 'https'; # optimistic, but...
1634
eval { require IO::Socket::SSL; };
1635
if ( $EVAL_ERROR ) {
1636
PTDEBUG && _d($EVAL_ERROR);
1637
$protocol = 'http';
1638
}
1639
PTDEBUG && _d('Using', $protocol);
1640
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",
1647
);
1648
if ( $advice ) {
1649
PTDEBUG && _d('Advice:', Dumper($advice));
1650
if ( scalar @$advice > 1) {
1651
print "\n# " . scalar @$advice . " software updates are "
1652
. "available:\n";
1653
}
1654
else {
1655
print "\n# A software update is available:\n";
1656
}
1657
print join("\n", map { "# * $_" } @$advice), "\n\n";
1658
}
1659
};
1660
if ( $EVAL_ERROR ) {
1661
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
1662
}
1663
1664
if ( @$instances_to_check ) {
1665
eval {
1666
update_check_times(
1667
instances => $instances_to_check,
1668
vc_file => $args{vc_file}, # testing
1669
now => $args{now}, # testing
1670
);
1671
};
1672
if ( $EVAL_ERROR ) {
1673
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
1674
}
1675
}
1676
1677
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
1678
warn "Exiting because the PTDEBUG_VERSION_CHECK "
1679
. "environment variable is defined.\n";
1680
exit 255;
1681
}
1682
1683
return;
1684
}
1685
1686
sub get_instances_to_check {
1687
my (%args) = @_;
1688
1689
my $instances = $args{instances};
1690
my $now = $args{now} || int(time);
1691
my $vc_file = $args{vc_file} || version_check_file();
1692
1693
if ( !-f $vc_file ) {
1694
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
1695
'version checking all instances');
1696
return $instances;
1697
}
1698
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);
1702
close $fh;
1703
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
1704
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',
1712
sprintf '%.2f',
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;
1718
}
1719
}
1720
1721
return \@instances_to_check;
1722
}
1723
1724
sub update_check_times {
1725
my (%args) = @_;
1726
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);
1731
1732
my %all_instances = map {
1733
$_->{id} => { name => $_->{name}, ts => $now }
1734
} @$instances;
1735
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> };
1739
close $fh;
1740
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
1745
}
1746
}
1747
}
1748
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";
1753
}
1754
close $fh;
1755
1756
return;
1757
}
1758
1759
sub get_instance_id {
1760
my ($instance) = @_;
1761
1762
my $dbh = $instance->{dbh};
1763
my $dsn = $instance->{dsn};
1764
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);
1776
}
1777
else {
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 || '';
1783
}
1784
}
1785
my $id = md5_hex($name);
1786
1787
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
1788
1789
return $name, $id;
1790
}
1791
1792
1793
sub pingback {
1794
my (%args) = @_;
1795
my @required_args = qw(url instances);
1796
foreach my $arg ( @required_args ) {
1797
die "I need a $arg arugment" unless $args{$arg};
1798
}
1799
my $url = $args{url};
1800
my $instances = $args{instances};
1801
1802
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
1803
1804
my $response = $ua->request('GET', $url);
1805
PTDEBUG && _d('Server response:', Dumper($response));
1806
die "No response from GET $url"
1807
if !$response;
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};
1812
1813
my $items = parse_server_response(
1814
response => $response->{content}
1815
);
1816
die "Failed to parse server requested programs: $response->{content}"
1817
if !scalar keys %$items;
1818
1819
my $versions = get_versions(
1820
items => $items,
1821
instances => $instances,
1822
);
1823
die "Failed to get any program versions; should have at least gotten Perl"
1824
if !scalar keys %$versions;
1825
1826
my $client_content = encode_client_response(
1827
items => $items,
1828
versions => $versions,
1829
general_id => md5_hex( hostname() ),
1830
);
1831
1832
my $client_response = {
1833
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
1834
content => $client_content,
1835
};
1836
PTDEBUG && _d('Client response:', Dumper($client_response));
1837
1838
$response = $ua->request('POST', $url, $client_response);
1839
PTDEBUG && _d('Server suggestions:', Dumper($response));
1840
die "No response from POST $url $client_response"
1841
if !$response;
1842
die "POST $url returned HTTP status $response->{status}; expected 200"
1843
if $response->{status} != 200;
1844
1845
return unless $response->{content};
1846
1847
$items = parse_server_response(
1848
response => $response->{content},
1849
split_vars => 0,
1850
);
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} }
1855
values %$items;
1856
1857
return \@suggestions;
1858
}
1859
1860
sub encode_client_response {
1861
my (%args) = @_;
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};
1865
}
1866
my ($items, $versions, $general_id) = @args{@required_args};
1867
1868
my @lines;
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});
1875
}
1876
}
1877
else {
1878
push @lines, join(';', $general_id, $item, $versions->{$item});
1879
}
1880
}
1881
1882
my $client_response = join("\n", @lines) . "\n";
1883
return $client_response;
1884
}
1885
1886
sub parse_server_response {
1887
my (%args) = @_;
1888
my @required_args = qw(response);
1889
foreach my $arg ( @required_args ) {
1890
die "I need a $arg arugment" unless $args{$arg};
1891
}
1892
my ($response) = @args{@required_args};
1893
1894
my %items = map {
1895
my ($item, $type, $vars) = split(";", $_);
1896
if ( !defined $args{split_vars} || $args{split_vars} ) {
1897
$vars = [ split(",", ($vars || '')) ];
1898
}
1899
$item => {
1900
item => $item,
1901
type => $type,
1902
vars => $vars,
1903
};
1904
} split("\n", $response);
1905
1906
PTDEBUG && _d('Items:', Dumper(\%items));
1907
1908
return \%items;
1909
}
1910
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,
1916
);
1917
1918
sub valid_item {
1919
my ($item) = @_;
1920
return unless $item;
1921
if ( !exists $sub_for_type{ $item->{type} } ) {
1922
PTDEBUG && _d('Invalid type:', $item->{type});
1923
return 0;
1924
}
1925
return 1;
1926
}
1927
1928
sub get_versions {
1929
my (%args) = @_;
1930
my @required_args = qw(items);
1931
foreach my $arg ( @required_args ) {
1932
die "I need a $arg arugment" unless $args{$arg};
1933
}
1934
my ($items) = @args{@required_args};
1935
1936
my %versions;
1937
foreach my $item ( values %$items ) {
1938
next unless valid_item($item);
1939
eval {
1940
my $version = $sub_for_type{ $item->{type} }->(
1941
item => $item,
1942
instances => $args{instances},
1943
);
1944
if ( $version ) {
1945
chomp $version unless ref($version);
1946
$versions{$item->{item}} = $version;
1947
}
1948
};
1949
if ( $EVAL_ERROR ) {
1950
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
1951
}
1952
}
1953
1954
return \%versions;
1955
}
1956
1957
1958
sub get_os_version {
1959
if ( $OSNAME eq 'MSWin32' ) {
1960
require Win32;
1961
return Win32::GetOSDisplayName();
1962
}
1963
1964
chomp(my $platform = `uname -s`);
1965
PTDEBUG && _d('platform:', $platform);
1966
return $OSNAME unless $platform;
1967
1968
chomp(my $lsb_release
1969
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
1970
PTDEBUG && _d('lsb_release:', $lsb_release);
1971
1972
my $release = "";
1973
1974
if ( $platform eq 'Linux' ) {
1975
if ( -f "/etc/fedora-release" ) {
1976
$release = `cat /etc/fedora-release`;
1977
}
1978
elsif ( -f "/etc/redhat-release" ) {
1979
$release = `cat /etc/redhat-release`;
1980
}
1981
elsif ( -f "/etc/system-release" ) {
1982
$release = `cat /etc/system-release`;
1983
}
1984
elsif ( $lsb_release ) {
1985
$release = `$lsb_release -ds`;
1986
}
1987
elsif ( -f "/etc/lsb-release" ) {
1988
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
1989
$release =~ s/^\w+="([^"]+)".+/$1/;
1990
}
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;
1997
}
1998
}
1999
elsif ( -f "/etc/os-release" ) { # openSUSE
2000
chomp($release = `grep PRETTY_NAME /etc/os-release`);
2001
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
2002
}
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`;
2006
}
2007
else {
2008
$release = `cat /etc/*release | head -n1`;
2009
}
2010
}
2011
}
2012
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
2013
my $rel = `uname -r`;
2014
$release = "$platform $rel";
2015
}
2016
elsif ( $platform eq "SunOS" ) {
2017
my $rel = `head -n1 /etc/release` || `uname -r`;
2018
$release = "$platform $rel";
2019
}
2020
2021
if ( !$release ) {
2022
PTDEBUG && _d('Failed to get the release, using platform');
2023
$release = $platform;
2024
}
2025
chomp($release);
2026
2027
$release =~ s/^"|"$//g;
2028
2029
PTDEBUG && _d('OS version =', $release);
2030
return $release;
2031
}
2032
2033
sub get_perl_version {
2034
my (%args) = @_;
2035
my $item = $args{item};
2036
return unless $item;
2037
2038
my $version = sprintf '%vd', $PERL_VERSION;
2039
PTDEBUG && _d('Perl version', $version);
2040
return $version;
2041
}
2042
2043
sub get_perl_module_version {
2044
my (%args) = @_;
2045
my $item = $args{item};
2046
return unless $item;
2047
2048
my $var = '$' . $item->{item} . '::VERSION';
2049
my $version = eval "use $item->{item}; $var;";
2050
PTDEBUG && _d('Perl version for', $var, '=', $version);
2051
return $version;
2052
}
2053
2054
sub get_mysql_variable {
2055
return get_from_mysql(
2056
show => 'VARIABLES',
2057
@_,
2058
);
2059
}
2060
2061
sub get_from_mysql {
2062
my (%args) = @_;
2063
my $show = $args{show};
2064
my $item = $args{item};
2065
my $instances = $args{instances};
2066
return unless $show && $item;
2067
2068
if ( !$instances || !@$instances ) {
2069
PTDEBUG && _d('Cannot check', $item,
2070
'because there are no MySQL instances');
2071
return;
2072
}
2073
2074
my @versions;
2075
my %version_for;
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');
2083
2084
my @versions;
2085
foreach my $var ( @{$item->{vars}} ) {
2086
$var = lc($var);
2087
my $version = $rows->{$var}->{value};
2088
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
2089
'on', $instance->{name});
2090
push @versions, $version;
2091
}
2092
$version_for{ $instance->{id} } = join(' ', @versions);
2093
}
2094
2095
return \%version_for;
2096
}
2097
2098
sub _d {
2099
my ($package, undef, $line) = caller 0;
2100
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2101
map { defined $_ ? $_ : 'undef' }
2102
@_;
2103
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2104
}
2105
2106
1;
2107
}
2108
# ###########################################################################
2109
# End VersionCheck package
2110
# ###########################################################################
2111
2112
# ###########################################################################
2113
# DSNParser package
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,
2116
# lib/DSNParser.pm
2117
# t/lib/DSNParser.t
2118
# See https://launchpad.net/percona-toolkit for more information.
2119
# ###########################################################################
2120
{
2121
package DSNParser;
2122
2123
use strict;
2124
use warnings FATAL => 'all';
2125
use English qw(-no_match_vars);
2126
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2127
2128
use Data::Dumper;
2129
$Data::Dumper::Indent = 0;
2130
$Data::Dumper::Quotekeys = 0;
2131
2132
my $dsn_sep = qr/(?<!\\),/;
2133
2134
eval {
2135
require DBI;
2136
};
2137
my $have_dbi = $EVAL_ERROR ? 0 : 1;
2138
2139
sub new {
2140
my ( $class, %args ) = @_;
2141
foreach my $arg ( qw(opts) ) {
2142
die "I need a $arg argument" unless $args{$arg};
2143
}
2144
my $self = {
2145
opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
2146
};
2147
foreach my $opt ( @{$args{opts}} ) {
2148
if ( !$opt->{key} || !$opt->{desc} ) {
2149
die "Invalid DSN option: ", Dumper($opt);
2150
}
2151
PTDEBUG && _d('DSN option:',
2152
join(', ',
2153
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
2154
keys %$opt
2155
)
2156
);
2157
$self->{opts}->{$opt->{key}} = {
2158
dsn => $opt->{dsn},
2159
desc => $opt->{desc},
2160
copy => $opt->{copy} || 0,
2161
};
2162
}
2163
return bless $self, $class;
2164
}
2165
2166
sub prop {
2167
my ( $self, $prop, $value ) = @_;
2168
if ( @_ > 2 ) {
2169
PTDEBUG && _d('Setting', $prop, 'property');
2170
$self->{$prop} = $value;
2171
}
2172
return $self->{$prop};
2173
}
2174
2175
sub parse {
2176
my ( $self, $dsn, $prev, $defaults ) = @_;
2177
if ( !$dsn ) {
2178
PTDEBUG && _d('No DSN to parse');
2179
return;
2180
}
2181
PTDEBUG && _d('Parsing', $dsn);
2182
$prev ||= {};
2183
$defaults ||= {};
2184
my %given_props;
2185
my %final_props;
2186
my $opts = $self->{opts};
2187
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;
2192
}
2193
else {
2194
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
2195
$given_props{h} = $dsn_part;
2196
}
2197
}
2198
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} )
2204
{
2205
$final_props{$key} = $prev->{$key};
2206
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
2207
}
2208
if ( !defined $final_props{$key} ) {
2209
$final_props{$key} = $defaults->{$key};
2210
PTDEBUG && _d('Copying value for', $key, 'from defaults');
2211
}
2212
}
2213
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};
2219
}
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};
2226
}
2227
}
2228
2229
return \%final_props;
2230
}
2231
2232
sub parse_options {
2233
my ( $self, $o ) = @_;
2234
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
2235
my $dsn_string
2236
= join(',',
2237
map { "$_=".$o->get($_); }
2238
grep { $o->has($_) && $o->get($_) }
2239
keys %{$self->{opts}}
2240
);
2241
PTDEBUG && _d('DSN string made from options:', $dsn_string);
2242
return $self->parse($dsn_string);
2243
}
2244
2245
sub as_string {
2246
my ( $self, $dsn, $props ) = @_;
2247
return $dsn unless ref $dsn;
2248
my @keys = $props ? @$props : sort keys %$dsn;
2249
return join(',',
2250
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
2251
grep {
2252
exists $self->{opts}->{$_}
2253
&& exists $dsn->{$_}
2254
&& defined $dsn->{$_}
2255
} @keys);
2256
}
2257
2258
sub usage {
2259
my ( $self ) = @_;
2260
my $usage
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 ) {
2266
$usage .= " $key "
2267
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
2268
. ($opts{$key}->{desc} || '[No description]')
2269
. "\n";
2270
}
2271
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
2272
return $usage;
2273
}
2274
2275
sub get_cxn_params {
2276
my ( $self, $info ) = @_;
2277
my $dsn;
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->{$_} }
2284
qw(h P));
2285
}
2286
else {
2287
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
2288
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
2289
grep { defined $info->{$_} }
2290
qw(F h P S A))
2291
. ';mysql_read_default_group=client'
2292
. ($info->{L} ? ';mysql_local_infile=1' : '');
2293
}
2294
PTDEBUG && _d($dsn);
2295
return ($dsn, $info->{u}, $info->{p});
2296
}
2297
2298
sub fill_in_dsn {
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()');
2302
$user =~ s/@.*//;
2303
$dsn->{h} ||= $vars->{hostname}->{Value};
2304
$dsn->{S} ||= $vars->{'socket'}->{Value};
2305
$dsn->{P} ||= $vars->{port}->{Value};
2306
$dsn->{u} ||= $user;
2307
$dsn->{D} ||= $db;
2308
}
2309
2310
sub get_dbh {
2311
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
2312
$opts ||= {};
2313
my $defaults = {
2314
AutoCommit => 0,
2315
RaiseError => 1,
2316
PrintError => 0,
2317
ShowErrorStatement => 1,
2318
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
2319
};
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;
2323
}
2324
2325
if ( $opts->{mysql_use_result} ) {
2326
$defaults->{mysql_use_result} = 1;
2327
}
2328
2329
if ( !$have_dbi ) {
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";
2336
2337
}
2338
2339
my $dbh;
2340
my $tries = 2;
2341
while ( !$dbh && $tries-- ) {
2342
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
2343
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
2344
2345
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
2346
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";
2356
}
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};
2360
}
2361
if ( !$tries ) {
2362
die $EVAL_ERROR;
2363
}
2364
}
2365
}
2366
2367
if ( $cxn_string =~ m/mysql/i ) {
2368
my $sql;
2369
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";
2375
}
2376
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";
2383
}
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";
2388
}
2389
else {
2390
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
2391
}
2392
}
2393
2394
if ( my $vars = $self->prop('set-vars') ) {
2395
$self->set_vars($dbh, $vars);
2396
}
2397
2398
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
2399
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
2400
. ($sql_mode ? ",$sql_mode" : '')
2401
. '\'*/';
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" : '')
2407
. ": $EVAL_ERROR";
2408
}
2409
}
2410
2411
PTDEBUG && _d('DBH info: ',
2412
$dbh,
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,
2420
);
2421
2422
return $dbh;
2423
}
2424
2425
sub get_hostname {
2426
my ( $self, $dbh ) = @_;
2427
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
2428
return $host;
2429
}
2430
my ( $hostname, $one ) = $dbh->selectrow_array(
2431
'SELECT /*!50038 @@hostname, */ 1');
2432
return $hostname;
2433
}
2434
2435
sub disconnect {
2436
my ( $self, $dbh ) = @_;
2437
PTDEBUG && $self->print_active_handles($dbh);
2438
$dbh->disconnect;
2439
}
2440
2441
sub print_active_handles {
2442
my ( $self, $thing, $level ) = @_;
2443
$level ||= 0;
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 );
2449
}
2450
}
2451
2452
sub copy {
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;
2456
my %new_dsn = map {
2457
my $key = $_;
2458
my $val;
2459
if ( $args{overwrite} ) {
2460
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
2461
}
2462
else {
2463
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
2464
}
2465
$key => $val;
2466
} keys %{$self->{opts}};
2467
return \%new_dsn;
2468
}
2469
2470
sub set_vars {
2471
my ($self, $dbh, $vars) = @_;
2472
2473
return unless $vars;
2474
2475
foreach my $var ( sort keys %$vars ) {
2476
my $val = $vars->{$var}->{val};
2477
2478
(my $quoted_var = $var) =~ s/_/\\_/;
2479
my ($var_exists, $current_val);
2480
eval {
2481
($var_exists, $current_val) = $dbh->selectrow_array(
2482
"SHOW VARIABLES LIKE '$quoted_var'");
2483
};
2484
my $e = $EVAL_ERROR;
2485
if ( $e ) {
2486
PTDEBUG && _d($e);
2487
}
2488
2489
if ( $vars->{$var}->{default} && !$var_exists ) {
2490
PTDEBUG && _d('Not setting default var', $var,
2491
'because it does not exist');
2492
next;
2493
}
2494
2495
if ( $current_val && $current_val eq $val ) {
2496
PTDEBUG && _d('Not setting var', $var, 'because its value',
2497
'is already', $val);
2498
next;
2499
}
2500
2501
my $sql = "SET SESSION $var=$val";
2502
PTDEBUG && _d($dbh, $sql);
2503
eval { $dbh->do($sql) };
2504
if ( my $set_error = $EVAL_ERROR ) {
2505
chomp($set_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.";
2513
}
2514
warn $msg . "\n\n";
2515
}
2516
}
2517
2518
return;
2519
}
2520
2521
sub _d {
2522
my ($package, undef, $line) = caller 0;
2523
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2524
map { defined $_ ? $_ : 'undef' }
2525
@_;
2526
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2527
}
2528
2529
1;
2530
}
2531
# ###########################################################################
2532
# End DSNParser package
2533
# ###########################################################################
2534
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
# ###########################################################################
2543
{
2544
package OptionParser;
2545
2546
use strict;
2547
use warnings FATAL => 'all';
2548
use English qw(-no_match_vars);
2549
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2550
2551
use List::Util qw(max);
2552
use Getopt::Long;
2553
use Data::Dumper;
2554
2555
my $POD_link_re = '[LC]<"?([^">]+)"?>';
2556
2557
sub new {
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};
2562
}
2563
2564
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
2565
$program_name ||= $PROGRAM_NAME;
2566
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
2567
2568
my %attributes = (
2569
'type' => 1,
2570
'short form' => 1,
2571
'group' => 1,
2572
'default' => 1,
2573
'cumulative' => 1,
2574
'negatable' => 1,
2575
);
2576
2577
my $self = {
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.
2583
2584
%args,
2585
2586
strict => 1, # disabled by a special rule
2587
program_name => $program_name,
2588
opts => {},
2589
got_opts => 0,
2590
short_opts => {},
2591
defaults => {},
2592
groups => {},
2593
allowed_groups => {},
2594
errors => [],
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
2600
DSNParser => undef,
2601
default_files => [
2602
"/etc/percona-toolkit/percona-toolkit.conf",
2603
"/etc/percona-toolkit/$program_name.conf",
2604
"$home/.percona-toolkit.conf",
2605
"$home/.$program_name.conf",
2606
],
2607
types => {
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
2615
DSN => 'd', # DSN
2616
size => 'z', # size with kMG suffix (powers of 2^10)
2617
time => 'm', # time, with an optional suffix of s/h/m/d
2618
},
2619
};
2620
2621
return bless $self, $class;
2622
}
2623
2624
sub get_specs {
2625
my ( $self, $file ) = @_;
2626
$file ||= $self->{file} || __FILE__;
2627
my @specs = $self->_pod_to_specs($file);
2628
$self->_parse_specs(@specs);
2629
2630
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
2631
my $contents = do { local $/ = undef; <$fh> };
2632
close $fh;
2633
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
2634
PTDEBUG && _d('Parsing DSN OPTIONS');
2635
my $dsn_attribs = {
2636
dsn => 1,
2637
copy => 1,
2638
};
2639
my $parse_dsn_attribs = sub {
2640
my ( $self, $option, $attribs ) = @_;
2641
map {
2642
my $val = $attribs->{$_};
2643
if ( $val ) {
2644
$val = $val eq 'yes' ? 1
2645
: $val eq 'no' ? 0
2646
: $val;
2647
$attribs->{$_} = $val;
2648
}
2649
} keys %$attribs;
2650
return {
2651
key => $option,
2652
%$attribs,
2653
};
2654
};
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,
2663
);
2664
my @dsn_opts = map {
2665
my $opts = {
2666
key => $_->{spec}->{key},
2667
dsn => $_->{spec}->{dsn},
2668
copy => $_->{spec}->{copy},
2669
desc => $_->{desc},
2670
};
2671
$opts;
2672
} $dsn_o->_pod_to_specs($file);
2673
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
2674
}
2675
2676
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
2677
$self->{version} = $1;
2678
PTDEBUG && _d($self->{version});
2679
}
2680
2681
return;
2682
}
2683
2684
sub DSNParser {
2685
my ( $self ) = @_;
2686
return $self->{DSNParser};
2687
};
2688
2689
sub get_defaults_files {
2690
my ( $self ) = @_;
2691
return @{$self->{default_files}};
2692
}
2693
2694
sub _pod_to_specs {
2695
my ( $self, $file ) = @_;
2696
$file ||= $self->{file} || __FILE__;
2697
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
2698
2699
my @specs = ();
2700
my @rules = ();
2701
my $para;
2702
2703
local $INPUT_RECORD_SEPARATOR = '';
2704
while ( $para = <$fh> ) {
2705
next unless $para =~ m/^=head1 $self->{head1}/;
2706
last;
2707
}
2708
2709
while ( $para = <$fh> ) {
2710
last if $para =~ m/^=over/;
2711
next if $self->{skip_rules};
2712
chomp $para;
2713
$para =~ s/\s+/ /g;
2714
$para =~ s/$POD_link_re/$1/go;
2715
PTDEBUG && _d('Option rule:', $para);
2716
push @rules, $para;
2717
}
2718
2719
die "POD has no $self->{head1} section" unless $para;
2720
2721
do {
2722
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
2723
chomp $para;
2724
PTDEBUG && _d($para);
2725
my %attribs;
2726
2727
$para = <$fh>; # read next paragraph, possibly attributes
2728
2729
if ( $para =~ m/: / ) { # attributes
2730
$para =~ s/\s+\Z//g;
2731
%attribs = map {
2732
my ( $attrib, $val) = split(/: /, $_);
2733
die "Unrecognized attribute for --$option: $attrib"
2734
unless $self->{attributes}->{$attrib};
2735
($attrib, $val);
2736
} split(/; /, $para);
2737
if ( $attribs{'short form'} ) {
2738
$attribs{'short form'} =~ s/-//;
2739
}
2740
$para = <$fh>; # read next paragraph, probably short help desc
2741
}
2742
else {
2743
PTDEBUG && _d('Option has no attributes');
2744
}
2745
2746
$para =~ s/\s+\Z//g;
2747
$para =~ s/\s+/ /g;
2748
$para =~ s/$POD_link_re/$1/go;
2749
2750
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
2751
PTDEBUG && _d('Short help:', $para);
2752
2753
die "No description after option spec $option" if $para =~ m/^=item/;
2754
2755
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
2756
$option = $base_option;
2757
$attribs{'negatable'} = 1;
2758
}
2759
2760
push @specs, {
2761
spec => $self->{parse_attributes}->($self, $option, \%attribs),
2762
desc => $para
2763
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
2764
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
2765
};
2766
}
2767
while ( $para = <$fh> ) {
2768
last unless $para;
2769
if ( $para =~ m/^=head1/ ) {
2770
$para = undef; # Can't 'last' out of a do {} block.
2771
last;
2772
}
2773
last if $para =~ m/^=item /;
2774
}
2775
} while ( $para );
2776
2777
die "No valid specs in $self->{head1}" unless @specs;
2778
2779
close $fh;
2780
return @specs, @rules;
2781
}
2782
2783
sub _parse_specs {
2784
my ( $self, @specs ) = @_;
2785
my %disables; # special rule that requires deferred checking
2786
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);
2791
2792
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
2793
if ( !$long ) {
2794
die "Cannot parse long option from spec $opt->{spec}";
2795
}
2796
$opt->{long} = $long;
2797
2798
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
2799
$self->{opts}->{$long} = $opt;
2800
2801
if ( length $long == 1 ) {
2802
PTDEBUG && _d('Long opt', $long, 'looks like short opt');
2803
$self->{short_opts}->{$long} = $long;
2804
}
2805
2806
if ( $short ) {
2807
die "Duplicate short option -$short"
2808
if exists $self->{short_opts}->{$short};
2809
$self->{short_opts}->{$short} = $long;
2810
$opt->{short} = $short;
2811
}
2812
else {
2813
$opt->{short} = undef;
2814
}
2815
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;
2819
2820
$opt->{group} ||= 'default';
2821
$self->{groups}->{ $opt->{group} }->{$long} = 1;
2822
2823
$opt->{value} = undef;
2824
$opt->{got} = 0;
2825
2826
my ( $type ) = $opt->{spec} =~ m/=(.)/;
2827
$opt->{type} = $type;
2828
PTDEBUG && _d($long, 'type:', $type);
2829
2830
2831
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
2832
2833
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
2834
$self->{defaults}->{$long} = defined $def ? $def : 1;
2835
PTDEBUG && _d($long, 'default:', $def);
2836
}
2837
2838
if ( $long eq 'config' ) {
2839
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
2840
}
2841
2842
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
2843
$disables{$long} = $dis;
2844
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
2845
}
2846
2847
$self->{opts}->{$long} = $opt;
2848
}
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);
2853
my $rule_ok = 0;
2854
2855
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
2856
$rule_ok = 1;
2857
push @{$self->{mutex}}, \@participants;
2858
PTDEBUG && _d(@participants, 'are mutually exclusive');
2859
}
2860
if ( $opt =~ m/at least one|one and only one/ ) {
2861
$rule_ok = 1;
2862
push @{$self->{atleast1}}, \@participants;
2863
PTDEBUG && _d(@participants, 'require at least one');
2864
}
2865
if ( $opt =~ m/default to/ ) {
2866
$rule_ok = 1;
2867
$self->{defaults_to}->{$participants[0]} = $participants[1];
2868
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
2869
}
2870
if ( $opt =~ m/restricted to option groups/ ) {
2871
$rule_ok = 1;
2872
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
2873
my @groups = split(',', $groups);
2874
%{$self->{allowed_groups}->{$participants[0]}} = map {
2875
s/\s+//;
2876
$_ => 1;
2877
} @groups;
2878
}
2879
if( $opt =~ m/accepts additional command-line arguments/ ) {
2880
$rule_ok = 1;
2881
$self->{strict} = 0;
2882
PTDEBUG && _d("Strict mode disabled by rule");
2883
}
2884
2885
die "Unrecognized option rule: $opt" unless $rule_ok;
2886
}
2887
}
2888
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);
2893
}
2894
2895
return;
2896
}
2897
2898
sub _get_participants {
2899
my ( $self, $str ) = @_;
2900
my @participants;
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;
2905
}
2906
PTDEBUG && _d('Participants for', $str, ':', @participants);
2907
return @participants;
2908
}
2909
2910
sub opts {
2911
my ( $self ) = @_;
2912
my %opts = %{$self->{opts}};
2913
return %opts;
2914
}
2915
2916
sub short_opts {
2917
my ( $self ) = @_;
2918
my %short_opts = %{$self->{short_opts}};
2919
return %short_opts;
2920
}
2921
2922
sub set_defaults {
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});
2930
}
2931
return;
2932
}
2933
2934
sub get_defaults {
2935
my ( $self ) = @_;
2936
return $self->{defaults};
2937
}
2938
2939
sub get_groups {
2940
my ( $self ) = @_;
2941
return $self->{groups};
2942
}
2943
2944
sub _set_option {
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} ) {
2951
$opt->{value}++;
2952
}
2953
elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
2954
my $next_opt = $1;
2955
if ( exists $self->{opts}->{$next_opt}
2956
|| exists $self->{short_opts}->{$next_opt} ) {
2957
$self->save_error("--$long requires a string value");
2958
return;
2959
}
2960
else {
2961
$opt->{value} = $val;
2962
}
2963
}
2964
else {
2965
$opt->{value} = $val;
2966
}
2967
$opt->{got} = 1;
2968
PTDEBUG && _d('Got option', $long, '=', $val);
2969
}
2970
2971
sub get_opts {
2972
my ( $self ) = @_;
2973
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
2979
: undef;
2980
}
2981
$self->{got_opts} = 0;
2982
2983
$self->{errors} = [];
2984
2985
if ( @ARGV && $ARGV[0] eq "--config" ) {
2986
shift @ARGV;
2987
$self->_set_option('config', shift @ARGV);
2988
}
2989
if ( $self->has('config') ) {
2990
my @extra_args;
2991
foreach my $filename ( split(',', $self->get('config')) ) {
2992
eval {
2993
push @extra_args, $self->_read_config_file($filename);
2994
};
2995
if ( $EVAL_ERROR ) {
2996
if ( $self->got('config') ) {
2997
die $EVAL_ERROR;
2998
}
2999
elsif ( PTDEBUG ) {
3000
_d($EVAL_ERROR);
3001
}
3002
}
3003
}
3004
unshift @ARGV, @extra_args;
3005
}
3006
3007
Getopt::Long::Configure('no_ignore_case', 'bundling');
3008
GetOptions(
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');
3013
3014
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
3015
if ( $self->{version} ) {
3016
print $self->{version}, "\n";
3017
}
3018
else {
3019
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
3020
}
3021
exit 1;
3022
}
3023
3024
if ( @ARGV && $self->{strict} ) {
3025
$self->save_error("Unrecognized command-line options @ARGV");
3026
}
3027
3028
foreach my $mutex ( @{$self->{mutex}} ) {
3029
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
3030
if ( @set > 1 ) {
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);
3036
}
3037
}
3038
3039
foreach my $required ( @{$self->{atleast1}} ) {
3040
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
3041
if ( @set == 0 ) {
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");
3046
}
3047
}
3048
3049
$self->_check_opts( keys %{$self->{opts}} );
3050
$self->{got_opts} = 1;
3051
return;
3052
}
3053
3054
sub _check_opts {
3055
my ( $self, @long ) = @_;
3056
my $long_last = scalar @long;
3057
while ( @long ) {
3058
foreach my $i ( 0..$#long ) {
3059
my $long = $long[$i];
3060
next unless $long;
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');
3068
}
3069
3070
if ( exists $self->{allowed_groups}->{$long} ) {
3071
3072
my @restricted_groups = grep {
3073
!exists $self->{allowed_groups}->{$long}->{$_}
3074
} keys %{$self->{groups}};
3075
3076
my @restricted_opts;
3077
foreach my $restricted_group ( @restricted_groups ) {
3078
RESTRICTED_OPT:
3079
foreach my $restricted_opt (
3080
keys %{$self->{groups}->{$restricted_group}} )
3081
{
3082
next RESTRICTED_OPT if $restricted_opt eq $long;
3083
push @restricted_opts, $restricted_opt
3084
if $self->{opts}->{$restricted_opt}->{got};
3085
}
3086
}
3087
3088
if ( @restricted_opts ) {
3089
my $err;
3090
if ( @restricted_opts == 1 ) {
3091
$err = "--$restricted_opts[0]";
3092
}
3093
else {
3094
$err = join(', ',
3095
map { "--$self->{opts}->{$_}->{long}" }
3096
grep { $_ }
3097
@restricted_opts[0..scalar(@restricted_opts) - 2]
3098
)
3099
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
3100
}
3101
$self->save_error("--$long is not allowed with $err");
3102
}
3103
}
3104
3105
}
3106
elsif ( $opt->{is_required} ) {
3107
$self->save_error("Required option --$long must be specified");
3108
}
3109
3110
$self->_validate_type($opt);
3111
if ( $opt->{parsed} ) {
3112
delete $long[$i];
3113
}
3114
else {
3115
PTDEBUG && _d('Temporarily failed to parse', $long);
3116
}
3117
}
3118
3119
die "Failed to parse options, possibly due to circular dependencies"
3120
if @long == $long_last;
3121
$long_last = @long;
3122
}
3123
3124
return;
3125
}
3126
3127
sub _validate_type {
3128
my ( $self, $opt ) = @_;
3129
return unless $opt;
3130
3131
if ( !$opt->{type} ) {
3132
$opt->{parsed} = 1;
3133
return;
3134
}
3135
3136
my $val = $opt->{value};
3137
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])?$/;
3141
if ( !$suffix ) {
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, ')');
3146
}
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);
3154
}
3155
else {
3156
$self->save_error("Invalid time suffix for --$opt->{long}");
3157
}
3158
}
3159
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
3160
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
3161
my $prev = {};
3162
my $from_key = $self->{defaults_to}->{ $opt->{long} };
3163
if ( $from_key ) {
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};
3167
}
3168
else {
3169
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
3170
$from_key, 'parsed');
3171
return;
3172
}
3173
}
3174
my $defaults = $self->{DSNParser}->parse_options($self);
3175
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
3176
}
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);
3180
}
3181
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
3182
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
3183
}
3184
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
3185
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
3186
}
3187
else {
3188
PTDEBUG && _d('Nothing to validate for option',
3189
$opt->{long}, 'type', $opt->{type}, 'value', $val);
3190
}
3191
3192
$opt->{parsed} = 1;
3193
return;
3194
}
3195
3196
sub get {
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};
3202
}
3203
3204
sub got {
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};
3210
}
3211
3212
sub has {
3213
my ( $self, $opt ) = @_;
3214
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3215
return defined $long ? exists $self->{opts}->{$long} : 0;
3216
}
3217
3218
sub set {
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;
3224
return;
3225
}
3226
3227
sub save_error {
3228
my ( $self, $error ) = @_;
3229
push @{$self->{errors}}, $error;
3230
return;
3231
}
3232
3233
sub errors {
3234
my ( $self ) = @_;
3235
return $self->{errors};
3236
}
3237
3238
sub usage {
3239
my ( $self ) = @_;
3240
warn "No usage string is set" unless $self->{usage}; # XXX
3241
return "Usage: " . ($self->{usage} || '') . "\n";
3242
}
3243
3244
sub descr {
3245
my ( $self ) = @_;
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;
3254
return $descr;
3255
}
3256
3257
sub usage_or_errors {
3258
my ( $self, $file, $return ) = @_;
3259
$file ||= $self->{file} || __FILE__;
3260
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});
3268
}
3269
3270
if ( $self->{opts}->{help}->{got} ) {
3271
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
3272
exit 0 unless $return;
3273
}
3274
elsif ( scalar @{$self->{errors}} ) {
3275
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
3276
exit 1 unless $return;
3277
}
3278
3279
return;
3280
}
3281
3282
sub print_errors {
3283
my ( $self ) = @_;
3284
my $usage = $self->usage() . "\n";
3285
if ( (my @errors = @{$self->{errors}}) ) {
3286
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
3287
. "\n";
3288
}
3289
return $usage . "\n" . $self->descr();
3290
}
3291
3292
sub print_usage {
3293
my ( $self ) = @_;
3294
die "Run get_opts() before print_usage()" unless $self->{got_opts};
3295
my @opts = values %{$self->{opts}};
3296
3297
my $maxl = max(
3298
map {
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
3302
}
3303
@opts);
3304
3305
my $maxs = max(0,
3306
map {
3307
length($_)
3308
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
3309
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
3310
}
3311
values %{$self->{short_opts}});
3312
3313
my $lcol = max($maxl, ($maxs + 3));
3314
my $rcol = 80 - $lcol - 6;
3315
my $rpad = ' ' x ( 80 - $rcol );
3316
3317
$maxs = max($lcol - 3, $maxs);
3318
3319
my $usage = $self->descr() . "\n" . $self->usage();
3320
3321
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
3322
push @groups, 'default';
3323
3324
foreach my $group ( reverse @groups ) {
3325
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
3326
foreach my $opt (
3327
sort { $a->{long} cmp $b->{long} }
3328
grep { $_->{group} eq $group }
3329
@opts )
3330
{
3331
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
3332
my $short = $opt->{short};
3333
my $desc = $opt->{desc};
3334
3335
$long .= $opt->{type} ? "=$opt->{type}" : "";
3336
3337
if ( $opt->{type} && $opt->{type} eq 'm' ) {
3338
my ($s) = $desc =~ m/\(suffix (.)\)/;
3339
$s ||= 's';
3340
$desc =~ s/\s+\(suffix .\)//;
3341
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
3342
. "d=days; if no suffix, $s is used.";
3343
}
3344
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
3345
$desc =~ s/ +$//mg;
3346
if ( $short ) {
3347
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
3348
}
3349
else {
3350
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
3351
}
3352
}
3353
}
3354
3355
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
3356
3357
if ( (my @rules = @{$self->{rules}}) ) {
3358
$usage .= "\nRules:\n\n";
3359
$usage .= join("\n", map { " $_" } @rules) . "\n";
3360
}
3361
if ( $self->{DSNParser} ) {
3362
$usage .= "\n" . $self->{DSNParser}->usage();
3363
}
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)
3374
: $val;
3375
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
3376
}
3377
return $usage;
3378
}
3379
3380
sub prompt_noecho {
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";
3386
my $response;
3387
eval {
3388
require Term::ReadKey;
3389
Term::ReadKey::ReadMode('noecho');
3390
chomp($response = <STDIN>);
3391
Term::ReadKey::ReadMode('normal');
3392
print "\n"
3393
or die "Cannot print: $OS_ERROR";
3394
};
3395
if ( $EVAL_ERROR ) {
3396
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
3397
}
3398
return $response;
3399
}
3400
3401
sub _read_config_file {
3402
my ( $self, $filename ) = @_;
3403
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
3404
my @args;
3405
my $prefix = '--';
3406
my $parse = 1;
3407
3408
LINE:
3409
while ( my $line = <$fh> ) {
3410
chomp $line;
3411
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
3412
$line =~ s/\s+#.*$//g;
3413
$line =~ s/^\s+|\s+$//g;
3414
if ( $line eq '--' ) {
3415
$prefix = '';
3416
$parse = 0;
3417
next LINE;
3418
}
3419
if ( $parse
3420
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
3421
) {
3422
push @args, grep { defined $_ } ("$prefix$opt", $arg);
3423
}
3424
elsif ( $line =~ m/./ ) {
3425
push @args, $line;
3426
}
3427
else {
3428
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
3429
}
3430
}
3431
close $fh;
3432
return @args;
3433
}
3434
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 = '';
3439
my $para;
3440
while ( $para = <$fh> ) {
3441
next unless $para =~ m/^=pod$/m;
3442
last;
3443
}
3444
while ( $para = <$fh> ) {
3445
next unless $para =~ m/$regex/;
3446
last;
3447
}
3448
$para = <$fh>;
3449
chomp($para);
3450
close $fh or die "Can't close $file: $OS_ERROR";
3451
return $para;
3452
}
3453
3454
sub clone {
3455
my ( $self ) = @_;
3456
3457
my %clone = map {
3458
my $hashref = $self->{$_};
3459
my $val_copy = {};
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}} ]
3465
: $hashref->{$key};
3466
}
3467
$_ => $val_copy;
3468
} qw(opts short_opts defaults);
3469
3470
foreach my $scalar ( qw(got_opts) ) {
3471
$clone{$scalar} = $self->{$scalar};
3472
}
3473
3474
return bless \%clone;
3475
}
3476
3477
sub _parse_size {
3478
my ( $self, $opt, $val ) = @_;
3479
3480
if ( lc($val || '') eq 'null' ) {
3481
PTDEBUG && _d('NULL size for', $opt->{long});
3482
$opt->{value} = 'null';
3483
return;
3484
}
3485
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 ) {
3489
if ( $factor ) {
3490
$num *= $factor_for{$factor};
3491
PTDEBUG && _d('Setting option', $opt->{y},
3492
'to num', $num, '* factor', $factor);
3493
}
3494
$opt->{value} = ($pre || '') . $num;
3495
}
3496
else {
3497
$self->save_error("Invalid size for --$opt->{long}: $val");
3498
}
3499
return;
3500
}
3501
3502
sub _parse_attribs {
3503
my ( $self, $option, $attribs ) = @_;
3504
my $types = $self->{types};
3505
return $option
3506
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
3507
. ($attribs->{'negatable'} ? '!' : '' )
3508
. ($attribs->{'cumulative'} ? '+' : '' )
3509
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
3510
}
3511
3512
sub _parse_synopsis {
3513
my ( $self, $file ) = @_;
3514
$file ||= $self->{file} || __FILE__;
3515
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
3516
3517
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
3518
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
3519
my $para;
3520
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
3521
die "$file does not contain a SYNOPSIS section" unless $para;
3522
my @synop;
3523
for ( 1..2 ) { # 1 for the usage, 2 for the description
3524
my $para = <$fh>;
3525
push @synop, $para;
3526
}
3527
close $fh;
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;
3532
3533
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
3534
chomp $usage;
3535
3536
$desc =~ s/\n/ /g;
3537
$desc =~ s/\s{2,}/ /g;
3538
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
3539
$desc =~ s/\s+$//;
3540
3541
return (
3542
description => $desc,
3543
usage => $usage,
3544
);
3545
};
3546
3547
sub set_vars {
3548
my ($self, $file) = @_;
3549
$file ||= $self->{file} || __FILE__;
3550
3551
my %user_vars;
3552
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
3553
if ( $user_vars ) {
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} = {
3558
val => $val,
3559
default => 0,
3560
};
3561
}
3562
}
3563
3564
my %default_vars;
3565
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
3566
if ( $default_vars ) {
3567
%default_vars = map {
3568
my $var_val = $_;
3569
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
3570
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
3571
$var => {
3572
val => $val,
3573
default => 1,
3574
};
3575
} split("\n", $default_vars);
3576
}
3577
3578
my %vars = (
3579
%default_vars, # first the tool's defaults
3580
%user_vars, # then the user's which overwrite the defaults
3581
);
3582
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
3583
return \%vars;
3584
}
3585
3586
sub _d {
3587
my ($package, undef, $line) = caller 0;
3588
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3589
map { defined $_ ? $_ : 'undef' }
3590
@_;
3591
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3592
}
3593
3594
if ( PTDEBUG ) {
3595
print STDERR '# ', $^X, ' ', $], "\n";
3596
if ( my $uname = `uname -a` ) {
3597
$uname =~ s/\s+/ /g;
3598
print STDERR "# $uname\n";
3599
}
3600
print STDERR '# Arguments: ',
3601
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
3602
}
3603
3604
1;
3605
}
3606
# ###########################################################################
3607
# End OptionParser package
3608
# ###########################################################################
3609
3610
# ###########################################################################
3611
# Cxn package
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,
3614
# lib/Cxn.pm
3615
# t/lib/Cxn.t
3616
# See https://launchpad.net/percona-toolkit for more information.
3617
# ###########################################################################
3618
{
3619
package Cxn;
3620
3621
use strict;
3622
use warnings FATAL => 'all';
3623
use English qw(-no_match_vars);
3624
use Scalar::Util qw(blessed);
3625
use constant {
3626
PTDEBUG => $ENV{PTDEBUG} || 0,
3627
PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
3628
};
3629
3630
sub new {
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};
3635
};
3636
my ($dp, $o) = @args{@required_args};
3637
3638
my $dsn_defaults = $dp->parse_options($o);
3639
my $prev_dsn = $args{prev_dsn};
3640
my $dsn = $args{dsn};
3641
if ( !$dsn ) {
3642
$args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
3643
3644
$dsn = $dp->parse(
3645
$args{dsn_string}, $prev_dsn, $dsn_defaults);
3646
}
3647
elsif ( $prev_dsn ) {
3648
$dsn = $dp->copy($prev_dsn, $dsn);
3649
}
3650
3651
my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
3652
|| $dp->as_string($dsn, [qw(F)])
3653
|| '';
3654
3655
my $self = {
3656
dsn => $dsn,
3657
dbh => $args{dbh},
3658
dsn_name => $dsn_name,
3659
hostname => '',
3660
set => $args{set},
3661
NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
3662
dbh_set => 0,
3663
ask_pass => $args{ask_pass},
3664
DSNParser => $dp,
3665
is_cluster_node => undef,
3666
parent => $args{parent},
3667
};
3668
3669
return bless $self, $class;
3670
}
3671
3672
sub connect {
3673
my ( $self, %opts ) = @_;
3674
my $dsn = $opts{dsn} || $self->{dsn};
3675
my $dp = $self->{DSNParser};
3676
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;
3682
}
3683
$dbh = $dp->get_dbh(
3684
$dp->get_cxn_params($dsn),
3685
{
3686
AutoCommit => 1,
3687
%opts,
3688
},
3689
);
3690
}
3691
3692
$dbh = $self->set_dbh($dbh);
3693
if ( $opts{dsn} ) {
3694
$self->{dsn} = $dsn;
3695
$self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
3696
|| $dp->as_string($dsn, [qw(F)])
3697
|| '';
3698
3699
}
3700
PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
3701
return $dbh;
3702
}
3703
3704
sub set_dbh {
3705
my ($self, $dbh) = @_;
3706
3707
if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
3708
PTDEBUG && _d($dbh, 'Already set dbh');
3709
return $dbh;
3710
}
3711
3712
PTDEBUG && _d($dbh, 'Setting dbh');
3713
3714
$dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
3715
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);
3720
if ( $hostname ) {
3721
$self->{hostname} = $hostname;
3722
}
3723
3724
if ( $self->{parent} ) {
3725
PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
3726
$dbh->{InactiveDestroy} = 1;
3727
}
3728
3729
if ( my $set = $self->{set}) {
3730
$set->($dbh);
3731
}
3732
3733
$self->{dbh} = $dbh;
3734
$self->{dbh_set} = 1;
3735
return $dbh;
3736
}
3737
3738
sub lost_connection {
3739
my ($self, $e) = @_;
3740
return 0 unless $e;
3741
return $e =~ m/MySQL server has gone away/
3742
|| $e =~ m/Lost connection to MySQL server/;
3743
}
3744
3745
sub dbh {
3746
my ($self) = @_;
3747
return $self->{dbh};
3748
}
3749
3750
sub dsn {
3751
my ($self) = @_;
3752
return $self->{dsn};
3753
}
3754
3755
sub name {
3756
my ($self) = @_;
3757
return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
3758
return $self->{hostname} || $self->{dsn_name} || 'unknown host';
3759
}
3760
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));
3766
my @trimmed_cxns;
3767
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);
3774
3775
if ( ! $seen_ids->{$id}++ ) {
3776
push @trimmed_cxns, $cxn
3777
}
3778
else {
3779
PTDEBUG && _d("Removing ", $cxn->name,
3780
", ID ", $id, ", because we've already seen it");
3781
}
3782
}
3783
3784
return \@trimmed_cxns;
3785
}
3786
3787
sub DESTROY {
3788
my ($self) = @_;
3789
3790
PTDEBUG && _d('Destroying cxn');
3791
3792
if ( $self->{parent} ) {
3793
PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
3794
}
3795
elsif ( $self->{dbh}
3796
&& blessed($self->{dbh})
3797
&& $self->{dbh}->can("disconnect") )
3798
{
3799
PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
3800
$self->{dsn_name});
3801
$self->{dbh}->disconnect();
3802
}
3803
3804
return;
3805
}
3806
3807
sub _d {
3808
my ($package, undef, $line) = caller 0;
3809
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3810
map { defined $_ ? $_ : 'undef' }
3811
@_;
3812
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3813
}
3814
3815
1;
3816
}
3817
# ###########################################################################
3818
# End Cxn package
3819
# ###########################################################################
3820
3821
# ###########################################################################
3822
# Quoter package
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,
3825
# lib/Quoter.pm
3826
# t/lib/Quoter.t
3827
# See https://launchpad.net/percona-toolkit for more information.
3828
# ###########################################################################
3829
{
3830
package Quoter;
3831
3832
use strict;
3833
use warnings FATAL => 'all';
3834
use English qw(-no_match_vars);
3835
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3836
3837
use Data::Dumper;
3838
$Data::Dumper::Indent = 1;
3839
$Data::Dumper::Sortkeys = 1;
3840
$Data::Dumper::Quotekeys = 0;
3841
3842
sub new {
3843
my ( $class, %args ) = @_;
3844
return bless {}, $class;
3845
}
3846
3847
sub quote {
3848
my ( $self, @vals ) = @_;
3849
foreach my $val ( @vals ) {
3850
$val =~ s/`/``/g;
3851
}
3852
return join('.', map { '`' . $_ . '`' } @vals);
3853
}
3854
3855
sub quote_val {
3856
my ( $self, $val, %args ) = @_;
3857
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
3862
3863
return $val if $args{is_float};
3864
3865
$val =~ s/(['\\])/\\$1/g;
3866
return "'$val'";
3867
}
3868
3869
sub split_unquote {
3870
my ( $self, $db_tbl, $default_db ) = @_;
3871
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
3872
if ( !$tbl ) {
3873
$tbl = $db;
3874
$db = $default_db;
3875
}
3876
for ($db, $tbl) {
3877
next unless $_;
3878
s/\A`//;
3879
s/`\z//;
3880
s/``/`/g;
3881
}
3882
3883
return ($db, $tbl);
3884
}
3885
3886
sub literal_like {
3887
my ( $self, $like ) = @_;
3888
return unless $like;
3889
$like =~ s/([%_])/\\$1/g;
3890
return "'$like'";
3891
}
3892
3893
sub join_quote {
3894
my ( $self, $default_db, $db_tbl ) = @_;
3895
return unless $db_tbl;
3896
my ($db, $tbl) = split(/[.]/, $db_tbl);
3897
if ( !$tbl ) {
3898
$tbl = $db;
3899
$db = $default_db;
3900
}
3901
$db = "`$db`" if $db && $db !~ m/^`/;
3902
$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
3903
return $db ? "$db.$tbl" : $tbl;
3904
}
3905
3906
sub serialize_list {
3907
my ( $self, @args ) = @_;
3908
PTDEBUG && _d('Serializing', Dumper(\@args));
3909
return unless @args;
3910
3911
my @parts;
3912
foreach my $arg ( @args ) {
3913
if ( defined $arg ) {
3914
$arg =~ s/,/\\,/g; # escape commas
3915
$arg =~ s/\\N/\\\\N/g; # escape literal \N
3916
push @parts, $arg;
3917
}
3918
else {
3919
push @parts, '\N';
3920
}
3921
}
3922
3923
my $string = join(',', @parts);
3924
PTDEBUG && _d('Serialized: <', $string, '>');
3925
return $string;
3926
}
3927
3928
sub deserialize_list {
3929
my ( $self, $string ) = @_;
3930
PTDEBUG && _d('Deserializing <', $string, '>');
3931
die "Cannot deserialize an undefined string" unless defined $string;
3932
3933
my @parts;
3934
foreach my $arg ( split(/(?<!\\),/, $string) ) {
3935
if ( $arg eq '\N' ) {
3936
$arg = undef;
3937
}
3938
else {
3939
$arg =~ s/\\,/,/g;
3940
$arg =~ s/\\\\N/\\N/g;
3941
}
3942
push @parts, $arg;
3943
}
3944
3945
if ( !@parts ) {
3946
my $n_empty_strings = $string =~ tr/,//;
3947
$n_empty_strings++;
3948
PTDEBUG && _d($n_empty_strings, 'empty strings');
3949
map { push @parts, '' } 1..$n_empty_strings;
3950
}
3951
elsif ( $string =~ m/(?<!\\),$/ ) {
3952
PTDEBUG && _d('Last value is an empty string');
3953
push @parts, '';
3954
}
3955
3956
PTDEBUG && _d('Deserialized', Dumper(\@parts));
3957
return @parts;
3958
}
3959
3960
sub _d {
3961
my ($package, undef, $line) = caller 0;
3962
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3963
map { defined $_ ? $_ : 'undef' }
3964
@_;
3965
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3966
}
3967
3968
1;
3969
}
3970
# ###########################################################################
3971
# End Quoter package
3972
# ###########################################################################
3973
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
# ###########################################################################
3982
{
3983
package VersionParser;
3984
3985
use Lmo;
3986
use Scalar::Util qw(blessed);
3987
use English qw(-no_match_vars);
3988
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3989
3990
use overload (
3991
'""' => "version",
3992
'<=>' => "cmp",
3993
'cmp' => "cmp",
3994
fallback => 1,
3995
);
3996
3997
use Carp ();
3998
3999
has major => (
4000
is => 'ro',
4001
isa => 'Int',
4002
required => 1,
4003
);
4004
4005
has [qw( minor revision )] => (
4006
is => 'ro',
4007
isa => 'Num',
4008
);
4009
4010
has flavor => (
4011
is => 'ro',
4012
isa => 'Str',
4013
default => sub { 'Unknown' },
4014
);
4015
4016
has innodb_version => (
4017
is => 'ro',
4018
isa => 'Str',
4019
default => sub { 'NO' },
4020
);
4021
4022
sub series {
4023
my $self = shift;
4024
return $self->_join_version($self->major, $self->minor);
4025
}
4026
4027
sub version {
4028
my $self = shift;
4029
return $self->_join_version($self->major, $self->minor, $self->revision);
4030
}
4031
4032
sub is_in {
4033
my ($self, $target) = @_;
4034
4035
return $self eq $target;
4036
}
4037
4038
sub _join_version {
4039
my ($self, @parts) = @_;
4040
4041
return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts;
4042
}
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];
4047
}
4048
4049
sub normalized_version {
4050
my ( $self ) = @_;
4051
my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major,
4052
$self->minor,
4053
$self->revision);
4054
PTDEBUG && _d($self->version, 'normalizes to', $result);
4055
return $result;
4056
}
4057
4058
sub comment {
4059
my ( $self, $cmd ) = @_;
4060
my $v = $self->normalized_version();
4061
4062
return "/*!$v $cmd */"
4063
}
4064
4065
my @methods = qw(major minor revision);
4066
sub cmp {
4067
my ($left, $right) = @_;
4068
my $right_obj = (blessed($right) && $right->isa(ref($left)))
4069
? $right
4070
: ref($left)->new($right);
4071
4072
my $retval = 0;
4073
for my $m ( @methods ) {
4074
last unless defined($left->$m) && defined($right_obj->$m);
4075
$retval = $left->$m <=> $right_obj->$m;
4076
last if $retval;
4077
}
4078
return $retval;
4079
}
4080
4081
sub BUILDARGS {
4082
my $self = shift;
4083
4084
if ( @_ == 1 ) {
4085
my %args;
4086
if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) {
4087
PTDEBUG && _d("VersionParser got a dbh, trying to get the version");
4088
my $dbh = $_[0];
4089
local $dbh->{FetchHashKeyName} = 'NAME_lc';
4090
my $query = eval {
4091
$dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} })
4092
};
4093
if ( $query ) {
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};
4098
}
4099
elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) {
4100
@args{@methods} = $self->_split_version($query);
4101
}
4102
else {
4103
Carp::confess("Couldn't get the version from the dbh while "
4104
. "creating a VersionParser object: $@");
4105
}
4106
$args{innodb_version} = eval { $self->_innodb_version($dbh) };
4107
}
4108
elsif ( !ref($_[0]) ) {
4109
@args{@methods} = $self->_split_version($_[0]);
4110
}
4111
4112
for my $method (@methods) {
4113
delete $args{$method} unless defined $args{$method};
4114
}
4115
@_ = %args if %args;
4116
}
4117
4118
return $self->SUPER::BUILDARGS(@_);
4119
}
4120
4121
sub _innodb_version {
4122
my ( $self, $dbh ) = @_;
4123
return unless $dbh;
4124
my $innodb_version = "NO";
4125
4126
my ($innodb) =
4127
grep { $_->{engine} =~ m/InnoDB/i }
4128
map {
4129
my %hash;
4130
@hash{ map { lc $_ } keys %$_ } = values %$_;
4131
\%hash;
4132
}
4133
@{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
4134
if ( $innodb ) {
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});
4141
}
4142
else {
4143
$innodb_version = $innodb->{support}; # probably DISABLED or NO
4144
}
4145
}
4146
4147
PTDEBUG && _d("InnoDB version:", $innodb_version);
4148
return $innodb_version;
4149
}
4150
4151
sub _d {
4152
my ($package, undef, $line) = caller 0;
4153
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4154
map { defined $_ ? $_ : 'undef' }
4155
@_;
4156
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4157
}
4158
4159
no Lmo;
4160
1;
4161
}
4162
# ###########################################################################
4163
# End VersionParser package
4164
# ###########################################################################
4165
4166
# ###########################################################################
4167
# Daemon package
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,
4170
# lib/Daemon.pm
4171
# t/lib/Daemon.t
4172
# See https://launchpad.net/percona-toolkit for more information.
4173
# ###########################################################################
4174
{
4175
package Daemon;
4176
4177
use strict;
4178
use warnings FATAL => 'all';
4179
use English qw(-no_match_vars);
4180
4181
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4182
4183
use POSIX qw(setsid);
4184
use Fcntl qw(:DEFAULT);
4185
4186
sub new {
4187
my ($class, %args) = @_;
4188
my $self = {
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,
4195
};
4196
return bless $self, $class;
4197
}
4198
4199
sub run {
4200
my ($self) = @_;
4201
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};
4207
4208
PTDEBUG && _d('Starting daemon');
4209
4210
if ( $pid_file ) {
4211
eval {
4212
$self->_make_pid_file(
4213
pid => $PID, # parent's pid
4214
pid_file => $pid_file,
4215
);
4216
};
4217
die "$EVAL_ERROR\n" if $EVAL_ERROR;
4218
if ( !$daemonize ) {
4219
$self->{pid_file_owner} = $PID; # parent's pid
4220
}
4221
}
4222
4223
if ( $daemonize ) {
4224
defined (my $child_pid = fork()) or die "Cannot fork: $OS_ERROR";
4225
if ( $child_pid ) {
4226
PTDEBUG && _d('Forked child', $child_pid);
4227
$parent_exit->($child_pid) if $parent_exit;
4228
exit 0;
4229
}
4230
4231
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
4232
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
4233
4234
if ( $pid_file ) {
4235
$self->_update_pid_file(
4236
pid => $PID, # child's pid
4237
pid_file => $pid_file,
4238
);
4239
$self->{pid_file_owner} = $PID;
4240
}
4241
}
4242
4243
if ( $daemonize || $force_log_file ) {
4244
PTDEBUG && _d('Redirecting STDIN to /dev/null');
4245
close STDIN;
4246
open STDIN, '/dev/null'
4247
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
4248
if ( $log_file ) {
4249
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $log_file);
4250
close STDOUT;
4251
open STDOUT, '>>', $log_file
4252
or die "Cannot open log file $log_file: $OS_ERROR";
4253
4254
close STDERR;
4255
open STDERR, ">&STDOUT"
4256
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
4257
}
4258
else {
4259
if ( -t STDOUT ) {
4260
PTDEBUG && _d('No log file and STDOUT is a terminal;',
4261
'redirecting to /dev/null');
4262
close STDOUT;
4263
open STDOUT, '>', '/dev/null'
4264
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
4265
}
4266
if ( -t STDERR ) {
4267
PTDEBUG && _d('No log file and STDERR is a terminal;',
4268
'redirecting to /dev/null');
4269
close STDERR;
4270
open STDERR, '>', '/dev/null'
4271
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
4272
}
4273
}
4274
4275
$OUTPUT_AUTOFLUSH = 1;
4276
}
4277
4278
PTDEBUG && _d('Daemon running');
4279
return;
4280
}
4281
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};
4287
};
4288
my $pid = $args{pid};
4289
my $pid_file = $args{pid_file};
4290
4291
eval {
4292
sysopen(PID_FH, $pid_file, O_RDWR|O_CREAT|O_EXCL) or die $OS_ERROR;
4293
print PID_FH $PID, "\n";
4294
close PID_FH;
4295
};
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,
4300
pid => $PID,
4301
);
4302
if ( $old_pid ) {
4303
warn "Overwriting PID file $pid_file because PID $old_pid "
4304
. "is not running.\n";
4305
}
4306
$self->_update_pid_file(
4307
pid => $PID,
4308
pid_file => $pid_file
4309
);
4310
}
4311
else {
4312
die "Error creating PID file $pid_file: $e\n";
4313
}
4314
}
4315
4316
return;
4317
}
4318
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};
4324
};
4325
my $pid_file = $args{pid_file};
4326
my $pid = $args{pid};
4327
4328
PTDEBUG && _d('Checking if PID in', $pid_file, 'is running');
4329
4330
if ( ! -f $pid_file ) {
4331
PTDEBUG && _d('PID file', $pid_file, 'does not exist');
4332
return;
4333
}
4334
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;
4339
close $fh
4340
or die "Error closing $pid_file: $OS_ERROR";
4341
4342
if ( $existing_pid ) {
4343
if ( $existing_pid == $pid ) {
4344
warn "The current PID $pid already holds the PID file $pid_file\n";
4345
return;
4346
}
4347
else {
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";
4352
}
4353
}
4354
}
4355
else {
4356
die "PID file $pid_file exists but it is empty. Remove the file "
4357
. "if the process is no longer running.\n";
4358
}
4359
4360
return $existing_pid;
4361
}
4362
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};
4368
};
4369
my $pid = $args{pid};
4370
my $pid_file = $args{pid_file};
4371
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";
4376
close $fh
4377
or warn "Cannot close $pid_file: $OS_ERROR";
4378
4379
return;
4380
}
4381
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');
4389
}
4390
else {
4391
PTDEBUG && _d('No PID to remove');
4392
}
4393
return;
4394
}
4395
4396
sub DESTROY {
4397
my ($self) = @_;
4398
4399
if ( $self->{pid_file_owner} == $PID ) {
4400
$self->remove_pid_file();
4401
}
4402
4403
return;
4404
}
4405
4406
sub _d {
4407
my ($package, undef, $line) = caller 0;
4408
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4409
map { defined $_ ? $_ : 'undef' }
4410
@_;
4411
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4412
}
4413
4414
1;
4415
}
4416
# ###########################################################################
4417
# End Daemon package
4418
# ###########################################################################
4419
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
# ###########################################################################
4428
{
4429
package Transformers;
4430
4431
use strict;
4432
use warnings FATAL => 'all';
4433
use English qw(-no_match_vars);
4434
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4435
4436
use Time::Local qw(timegm timelocal);
4437
use Digest::MD5 qw(md5_hex);
4438
use B qw();
4439
4440
BEGIN {
4441
require Exporter;
4442
our @ISA = qw(Exporter);
4443
our %EXPORT_TAGS = ();
4444
our @EXPORT = ();
4445
our @EXPORT_OK = qw(
4446
micro_t
4447
percentage_of
4448
secs_to_time
4449
time_to_secs
4450
shorten
4451
ts
4452
parse_timestamp
4453
unix_timestamp
4454
any_unix_timestamp
4455
make_checksum
4456
crc32
4457
encode_json
4458
);
4459
}
4460
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
4464
4465
sub micro_t {
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
4469
my $f;
4470
4471
$t = 0 if $t < 0;
4472
4473
$t = sprintf('%.17f', $t) if $t =~ /e/;
4474
4475
$t =~ s/\.(\d{1,6})\d*/\.$1/;
4476
4477
if ($t > 0 && $t <= 0.000999) {
4478
$f = ($t * 1000000) . 'us';
4479
}
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
4483
}
4484
elsif ($t >= 1) {
4485
$f = sprintf("%.${p_s}f", $t);
4486
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
4487
}
4488
else {
4489
$f = 0; # $t should = 0 at this point
4490
}
4491
4492
return $f;
4493
}
4494
4495
sub percentage_of {
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);
4500
}
4501
4502
sub secs_to_time {
4503
my ( $secs, $fmt ) = @_;
4504
$secs ||= 0;
4505
return '00:00' unless $secs;
4506
4507
$fmt ||= $secs >= 86_400 ? 'd'
4508
: $secs >= 3_600 ? 'h'
4509
: 'm';
4510
4511
return
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),
4517
$secs % 60)
4518
: $fmt eq 'h' ? sprintf(
4519
"%02d:%02d:%02d",
4520
int(($secs % 86_400) / 3_600),
4521
int(($secs % 3_600) / 60),
4522
$secs % 60)
4523
: sprintf(
4524
"%02d:%02d",
4525
int(($secs % 3_600) / 60),
4526
$secs % 60);
4527
}
4528
4529
sub time_to_secs {
4530
my ( $val, $default_suffix ) = @_;
4531
die "I need a val argument" unless defined $val;
4532
my $t = 0;
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
4540
4541
$t *= -1 if $prefix && $prefix eq '-';
4542
}
4543
else {
4544
die "Invalid suffix for $val: $suffix";
4545
}
4546
return $t;
4547
}
4548
4549
sub shorten {
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
4553
my $n = 0;
4554
my @units = ('', qw(k M G T P E Z Y));
4555
while ( $num >= $d && $n < @units - 1 ) {
4556
$num /= $d;
4557
++$n;
4558
}
4559
return sprintf(
4560
$num =~ m/\./ || $n
4561
? "%.${p}f%s"
4562
: '%d',
4563
$num, $units[$n]);
4564
}
4565
4566
sub ts {
4567
my ( $time, $gmt ) = @_;
4568
my ( $sec, $min, $hour, $mday, $mon, $year )
4569
= $gmt ? gmtime($time) : localtime($time);
4570
$mon += 1;
4571
$year += 1900;
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);
4576
$us =~ s/^0\././;
4577
$val .= $us;
4578
}
4579
return $val;
4580
}
4581
4582
sub parse_timestamp {
4583
my ( $val ) = @_;
4584
if ( my($y, $m, $d, $h, $i, $s, $f)
4585
= $val =~ m/^$mysql_ts$/ )
4586
{
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);
4590
}
4591
elsif ( $val =~ m/^$proper_ts$/ ) {
4592
return $val;
4593
}
4594
return $val;
4595
}
4596
4597
sub unix_timestamp {
4598
my ( $val, $gmt ) = @_;
4599
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
4600
$val = $gmt
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);
4605
$us =~ s/^0\././;
4606
$val .= $us;
4607
}
4608
}
4609
return $val;
4610
}
4611
4612
sub any_unix_timestamp {
4613
my ( $val, $callback ) = @_;
4614
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);
4622
return time - $n;
4623
}
4624
elsif ( $val =~ m/^\d{9,}/ ) {
4625
PTDEBUG && _d('ts is already a unix timestamp');
4626
return $val;
4627
}
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));
4632
}
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);
4637
}
4638
else {
4639
PTDEBUG && _d('ts is MySQL expression');
4640
return $callback->($val) if $callback && ref $callback eq 'CODE';
4641
}
4642
4643
PTDEBUG && _d('Unknown ts type:', $val);
4644
return;
4645
}
4646
4647
sub make_checksum {
4648
my ( $val ) = @_;
4649
my $checksum = uc substr(md5_hex($val), -16);
4650
PTDEBUG && _d($checksum, 'checksum for', $val);
4651
return $checksum;
4652
}
4653
4654
sub crc32 {
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;
4661
for ( 1 .. 8 ) {
4662
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
4663
}
4664
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
4665
}
4666
return $crc ^ 0xFFFFFFFF;
4667
}
4668
4669
my $got_json = eval { require JSON };
4670
sub encode_json {
4671
return JSON::encode_json(@_) if $got_json;
4672
my ( $data ) = @_;
4673
return (object_to_json($data) || '');
4674
}
4675
4676
4677
sub object_to_json {
4678
my ($obj) = @_;
4679
my $type = ref($obj);
4680
4681
if($type eq 'HASH'){
4682
return hash_to_json($obj);
4683
}
4684
elsif($type eq 'ARRAY'){
4685
return array_to_json($obj);
4686
}
4687
else {
4688
return value_to_json($obj);
4689
}
4690
}
4691
4692
sub hash_to_json {
4693
my ($obj) = @_;
4694
my @res;
4695
for my $k ( sort { $a cmp $b } keys %$obj ) {
4696
push @res, string_to_json( $k )
4697
. ":"
4698
. ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) );
4699
}
4700
return '{' . ( @res ? join( ",", @res ) : '' ) . '}';
4701
}
4702
4703
sub array_to_json {
4704
my ($obj) = @_;
4705
my @res;
4706
4707
for my $v (@$obj) {
4708
push @res, object_to_json($v) || value_to_json($v);
4709
}
4710
4711
return '[' . ( @res ? join( ",", @res ) : '' ) . ']';
4712
}
4713
4714
sub value_to_json {
4715
my ($value) = @_;
4716
4717
return 'null' if(!defined $value);
4718
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?
4723
4724
my $type = ref($value);
4725
4726
if( !$type ) {
4727
return string_to_json($value);
4728
}
4729
else {
4730
return 'null';
4731
}
4732
4733
}
4734
4735
my %esc = (
4736
"\n" => '\n',
4737
"\r" => '\r',
4738
"\t" => '\t',
4739
"\f" => '\f',
4740
"\b" => '\b',
4741
"\"" => '\"',
4742
"\\" => '\\\\',
4743
"\'" => '\\\'',
4744
);
4745
4746
sub string_to_json {
4747
my ($arg) = @_;
4748
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;
4752
4753
utf8::upgrade($arg);
4754
utf8::encode($arg);
4755
4756
return '"' . $arg . '"';
4757
}
4758
4759
sub _d {
4760
my ($package, undef, $line) = caller 0;
4761
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4762
map { defined $_ ? $_ : 'undef' }
4763
@_;
4764
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4765
}
4766
4767
1;
4768
}
4769
# ###########################################################################
4770
# End Transformers package
4771
# ###########################################################################
4772
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,
4777
# lib/Safeguards.pm
4778
# t/lib/Safeguards.t
4779
# See https://launchpad.net/percona-toolkit for more information.
4780
# ###########################################################################
4781
{
4782
package Safeguards;
4783
4784
use strict;
4785
use warnings FATAL => 'all';
4786
use English qw(-no_match_vars);
4787
4788
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4789
4790
sub new {
4791
my ($class, %args) = @_;
4792
my $self = {
4793
disk_bytes_free => $args{disk_bytes_free} || 104857600, # 100 MiB
4794
disk_pct_free => $args{disk_pct_free} || 5,
4795
};
4796
return bless $self, $class;
4797
}
4798
4799
sub get_disk_space {
4800
my ($self, %args) = @_;
4801
my $filesystem = $args{filesystem} || $ENV{PWD};
4802
4803
my $disk_space = `df -P -k "$filesystem"`;
4804
chop($disk_space) if $disk_space;
4805
PTDEBUG && _d('Disk space on', $filesystem, $disk_space);
4806
4807
return $disk_space;
4808
}
4809
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);
4814
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"
4818
unless $partition;
4819
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);
4824
4825
$bytes_used = ($bytes_used || 0) * 1024;
4826
$bytes_free = ($bytes_free || 0) * 1024;
4827
4828
$pct_used =~ s/%//;
4829
my $pct_free = 100 - ($pct_used || 0);
4830
4831
return $bytes_free >= $self->{disk_bytes_free}
4832
&& $pct_free >= $self->{disk_pct_free};
4833
}
4834
4835
sub _d {
4836
my ($package, undef, $line) = caller 0;
4837
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4838
map { defined $_ ? $_ : 'undef' }
4839
@_;
4840
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4841
}
4842
4843
1;
4844
}
4845
# ###########################################################################
4846
# End Safeguards package
4847
# ###########################################################################
4848
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
# ###########################################################################
4857
{
4858
package Percona::Agent::Logger;
4859
4860
use strict;
4861
use warnings FATAL => 'all';
4862
use English qw(-no_match_vars);
4863
4864
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4865
4866
use POSIX qw(SIGALRM);
4867
4868
use Lmo;
4869
use Transformers;
4870
use Percona::WebAPI::Resource::LogEntry;
4871
4872
Transformers->import(qw(ts));
4873
4874
has 'exit_status' => (
4875
is => 'rw',
4876
isa => 'ScalarRef',
4877
required => 1,
4878
);
4879
4880
has 'pid' => (
4881
is => 'ro',
4882
isa => 'Int',
4883
required => 1,
4884
);
4885
4886
has 'service' => (
4887
is => 'rw',
4888
isa => 'Maybe[Str]',
4889
required => 0,
4890
default => sub { return; },
4891
);
4892
4893
has 'data_ts' => (
4894
is => 'rw',
4895
isa => 'Maybe[Int]',
4896
required => 0,
4897
default => sub { return; },
4898
);
4899
4900
has 'online_logging' => (
4901
is => 'ro',
4902
isa => 'Bool',
4903
required => 0,
4904
default => sub { return 1 },
4905
);
4906
4907
has 'online_logging_enabled' => (
4908
is => 'rw',
4909
isa => 'Bool',
4910
required => 0,
4911
default => sub { return 0 },
4912
);
4913
4914
has 'quiet' => (
4915
is => 'rw',
4916
isa => 'Int',
4917
required => 0,
4918
default => sub { return 0 },
4919
);
4920
4921
has '_buffer' => (
4922
is => 'rw',
4923
isa => 'ArrayRef',
4924
required => 0,
4925
default => sub { return []; },
4926
);
4927
4928
has '_pipe_write' => (
4929
is => 'rw',
4930
isa => 'Maybe[FileHandle]',
4931
required => 0,
4932
);
4933
4934
sub read_stdin {
4935
my ( $t ) = @_;
4936
4937
POSIX::sigaction(
4938
SIGALRM,
4939
POSIX::SigAction->new(sub { die 'read timeout'; }),
4940
) or die "Error setting SIGALRM handler: $OS_ERROR";
4941
4942
my $timeout = 0;
4943
my @lines;
4944
eval {
4945
alarm $t;
4946
while(defined(my $line = <STDIN>)) {
4947
push @lines, $line;
4948
}
4949
alarm 0;
4950
};
4951
if ( $EVAL_ERROR ) {
4952
PTDEBUG && _d('Read error:', $EVAL_ERROR);
4953
die $EVAL_ERROR unless $EVAL_ERROR =~ m/read timeout/;
4954
$timeout = 1;
4955
}
4956
return unless scalar @lines || $timeout;
4957
return \@lines;
4958
}
4959
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;
4965
4966
return unless $self->online_logging;
4967
4968
my $pid = open(my $pipe_write, "|-");
4969
4970
if ($pid) {
4971
select $pipe_write;
4972
$OUTPUT_AUTOFLUSH = 1;
4973
$self->_pipe_write($pipe_write);
4974
$self->online_logging_enabled(1);
4975
}
4976
else {
4977
my @log_entries;
4978
my $n_errors = 0;
4979
my $oktorun = 1;
4980
QUEUE:
4981
while ($oktorun) {
4982
my $lines = read_stdin($read_timeout);
4983
last QUEUE unless $lines;
4984
LINE:
4985
while ( defined(my $line = shift @$lines) ) {
4986
my ($ts, $level, $n_lines, $msg) = $line =~ m/^([^,]+),([^,]+),([^,]+),(.+)/s;
4987
if ( !$ts || !$level || !$n_lines || !$msg ) {
4988
warn "$line\n";
4989
next LINE;
4990
}
4991
if ( $n_lines > 1 ) {
4992
$n_lines--; # first line
4993
for ( 1..$n_lines ) {
4994
$msg .= shift @$lines;
4995
}
4996
}
4997
4998
push @log_entries, Percona::WebAPI::Resource::LogEntry->new(
4999
pid => $self->pid,
5000
entry_ts => $ts,
5001
log_level => $level,
5002
message => $msg,
5003
($self->service ? (service => $self->service) : ()),
5004
($self->data_ts ? (data_ts => $self->data_ts) : ()),
5005
);
5006
} # LINE
5007
5008
if ( scalar @log_entries ) {
5009
eval {
5010
$client->post(
5011
link => $log_link,
5012
resources => \@log_entries,
5013
);
5014
};
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";
5023
}
5024
}
5025
}
5026
else {
5027
@log_entries = ();
5028
$n_errors = 0;
5029
}
5030
} # have log entries
5031
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)];
5037
}
5038
} # QUEUE
5039
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",
5046
$log->entry_ts,
5047
level_name($log->log_level),
5048
$log->message,
5049
);
5050
}
5051
}
5052
5053
exit 0;
5054
} # child
5055
5056
return;
5057
}
5058
5059
sub level_number {
5060
my $name = shift;
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";
5068
}
5069
5070
sub level_name {
5071
my $number = shift;
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";
5079
}
5080
5081
sub debug {
5082
my $self = shift;
5083
return if $self->online_logging;
5084
return $self->_log(0, 'DEBUG', @_);
5085
}
5086
5087
sub info {
5088
my $self = shift;
5089
return $self->_log(1, 'INFO', @_);
5090
}
5091
5092
sub warning {
5093
my $self = shift;
5094
$self->_set_exit_status();
5095
return $self->_log(1, 'WARNING', @_);
5096
}
5097
5098
sub error {
5099
my $self = shift;
5100
$self->_set_exit_status();
5101
return $self->_log(1, 'ERROR', @_);
5102
}
5103
5104
sub fatal {
5105
my $self = shift;
5106
$self->_set_exit_status();
5107
$self->_log(1, 'FATAL', @_);
5108
exit $self->exit_status;
5109
}
5110
5111
sub _set_exit_status {
5112
my $self = shift;
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
5116
return;
5117
}
5118
5119
sub _log {
5120
my ($self, $online, $level, $msg) = @_;
5121
5122
my $ts = ts(time, 1); # 1=UTC
5123
my $level_number = level_number($level);
5124
5125
return if $self->quiet && $level_number < $self->quiet;
5126
5127
chomp($msg);
5128
my $n_lines = 1;
5129
$n_lines++ while $msg =~ m/\n/g;
5130
5131
if ( $online && $self->online_logging_enabled ) {
5132
while ( defined(my $log_entry = shift @{$self->_buffer}) ) {
5133
$self->_queue_log_entry(@$log_entry);
5134
}
5135
$self->_queue_log_entry($ts, $level_number, $n_lines, $msg);
5136
}
5137
else {
5138
if ( $online && $self->online_logging ) {
5139
push @{$self->_buffer}, [$ts, $level_number, $n_lines, $msg];
5140
}
5141
5142
if ( $level_number >= 3 ) { # warning
5143
print STDERR "$ts $level $msg\n";
5144
}
5145
else {
5146
print STDOUT "$ts $level $msg\n";
5147
}
5148
}
5149
5150
return;
5151
}
5152
5153
sub _queue_log_entry {
5154
my ($self, $ts, $log_level, $n_lines, $msg) = @_;
5155
print "$ts,$log_level,$n_lines,$msg\n";
5156
return;
5157
}
5158
5159
sub _d {
5160
my ($package, undef, $line) = caller 0;
5161
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
5162
map { defined $_ ? $_ : 'undef' }
5163
@_;
5164
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
5165
}
5166
5167
no Lmo;
5168
1;
5169
}
5170
# ###########################################################################
5171
# End Percona::Agent::Logger package
5172
# ###########################################################################
5173
5174
# ###########################################################################
5175
# Percona::Agent::Exception::*
5176
# ###########################################################################
5177
5178
{
5179
package Percona::Agent::Exception::PIDNotFound;
5180
5181
use Lmo;
5182
use overload '""' => \&as_string;
5183
5184
has 'pid_file' => (
5185
is => 'ro',
5186
isa => 'Maybe[Str]',
5187
required => 1,
5188
);
5189
5190
sub as_string {
5191
my $self = shift;
5192
return sprintf "PID file %s does not exist and no matching "
5193
. "process was found in ps", $self->pid_file;
5194
}
5195
5196
no Lmo;
5197
1;
5198
}
5199
5200
{
5201
package Percona::Agent::Exception::NoPID;
5202
5203
use Lmo;
5204
use overload '""' => \&as_string;
5205
5206
has 'pid_file' => (
5207
is => 'ro',
5208
isa => 'Maybe[Str]',
5209
required => 1,
5210
);
5211
5212
has 'pid_file_is_empty' => (
5213
is => 'ro',
5214
isa => 'Bool',
5215
required => 1,
5216
);
5217
5218
sub as_string {
5219
my $self = shift;
5220
if ( $self->pid_file_is_empty ) {
5221
return sprintf "PID file %s is empty", $self->pid_file;
5222
}
5223
else {
5224
return sprintf "PID file %s does not exist and parsing ps output "
5225
. "failed", $self->pid_file;
5226
}
5227
}
5228
5229
no Lmo;
5230
1;
5231
}
5232
5233
{
5234
package Percona::Agent::Exception::PIDNotRunning;
5235
5236
use Lmo;
5237
use overload '""' => \&as_string;
5238
5239
has 'pid' => (
5240
is => 'ro',
5241
isa => 'Str',
5242
required => 1,
5243
);
5244
5245
sub as_string {
5246
my $self = shift;
5247
return sprintf "PID is not running", $self->pid;
5248
}
5249
5250
no Lmo;
5251
1;
5252
}
5253
5254
BEGIN {
5255
$INC{'Percona/Agent/Exception/PIDNotFound.pm'} = __FILE__;
5256
$INC{'Percona/Agent/Exception/NoPID.pm'} = __FILE__;
5257
$INC{'Percona/Agent/Exception/PIDNotRunning.pm'} = __FILE__;
5258
}
5259
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.
5264
#
5265
# Check at the end of this package for the call to main() which actually runs
5266
# the program.
5267
# ###########################################################################
5268
package pt_agent;
5269
5270
use strict;
5271
use warnings FATAL => 'all';
5272
use English qw(-no_match_vars);
5273
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
5274
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);
5279
use File::Path;
5280
use File::Basename;
5281
use FindBin;
5282
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;
5294
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));
5298
5299
use sigtrap 'handler', \&sig_int, 'normal-signals';
5300
use sigtrap 'handler', \&reload_signal, 'USR1';
5301
5302
my $oktorun = 1;
5303
my $exit_status = 0;
5304
my $state = {};
5305
my $exit_on_signals = 0;
5306
my $logger;
5307
5308
use constant MAX_DATA_FILE_SIZE => 15_728_640; # 15M
5309
5310
my %deps = (
5311
'DBI'
5312
=> [qw(DBI libdbi-perl perl-DBI)],
5313
'DBD::mysql'
5314
=> [qw(DBD::mysql libdbd-mysql-perl perl-DBD-MySQL)],
5315
'JSON'
5316
=> [qw(JSON libjson-perl perl-JSON)],
5317
'LWP'
5318
=> [qw(LWP libwww-perl perl-libwww-perl)],
5319
'IO::Socket::SSL'
5320
=> [qw(IO::Socket::SSL libio-socket-ssl-perl perl-IO-Socket-SSL)],
5321
);
5322
5323
# Will check this later.
5324
eval {
5325
require JSON;
5326
};
5327
5328
sub main {
5329
local @ARGV = @_;
5330
5331
# Reset global vars else tests will fail in strange ways.
5332
$oktorun = 1;
5333
$exit_status = 0;
5334
$state = {};
5335
$exit_on_signals = 0;
5336
5337
# ########################################################################
5338
# Get configuration information.
5339
# ########################################################################
5340
my $o = new OptionParser();
5341
$o->get_specs();
5342
$o->get_opts();
5343
5344
my $dp = $o->DSNParser();
5345
$dp->prop('set-vars', $o->set_vars());
5346
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.
5350
if ( $EUID != 0 ) {
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');
5354
}
5355
5356
if ( !$o->get('help') ) {
5357
}
5358
5359
$o->usage_or_errors();
5360
5361
if ( $o->get('interactive')
5362
|| $o->get('install')
5363
|| $o->get('uninstall') ) {
5364
$OUTPUT_AUTOFLUSH = 1
5365
}
5366
5367
# ########################################################################
5368
# Fail-safe: if the agent somehow runs away, i.e. starts to fork-bomb,
5369
# stop everything.
5370
# ########################################################################
5371
my $lib_dir = $o->get('lib');
5372
if ( too_many_agents(lib_dir => $lib_dir) ) {
5373
schedule_services(
5374
services => [],
5375
lib_dir => $lib_dir,
5376
);
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";
5382
}
5383
5384
# ########################################################################
5385
# Connect to MysSQL later, maybe.
5386
# ########################################################################
5387
my $cxn = Cxn->new(
5388
dsn_string => '',
5389
OptionParser => $o,
5390
DSNParser => $dp,
5391
ask_pass => $o->get('ask-pass'),
5392
);
5393
5394
# ########################################################################
5395
# Make a logger, not online yet.
5396
# ########################################################################
5397
$logger = Percona::Agent::Logger->new(
5398
exit_status => \$exit_status,
5399
pid => $PID,
5400
online_logging => $o->get('log-api') ? 1 : 0,
5401
);
5402
5403
# ########################################################################
5404
# --(un)install and exit.
5405
# ########################################################################
5406
if ( $o->get('install') ) {
5407
$exit_on_signals = 1;
5408
install(
5409
OptionParser => $o,
5410
Cxn => $cxn,
5411
interactive => $o->get('interactive'),
5412
flags => $o->get('install-options'),
5413
);
5414
return $exit_status;
5415
}
5416
elsif ( $o->get('uninstall') ) {
5417
$exit_on_signals = 1;
5418
uninstall(
5419
OptionParser => $o,
5420
Cxn => $cxn,
5421
);
5422
return $exit_status;
5423
}
5424
5425
# ########################################################################
5426
# Nothing works without required Perl modules.
5427
# ########################################################################
5428
if ( missing_perl_module_deps() ) {
5429
$logger->fatal("Missing required Perl modules");
5430
}
5431
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"
5436
}
5437
5438
# ########################################################################
5439
# Nothing works without an API key.
5440
# ########################################################################
5441
my $api_key = $o->get('api-key');
5442
if ( !$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.");
5446
}
5447
5448
# ########################################################################
5449
# --status, --stop, and --reset
5450
# ########################################################################
5451
if ( $o->get('status') ) {
5452
agent_status(
5453
api_key => $o->get('api-key'),
5454
pid_file => $o->get('pid'),
5455
lib_dir => $o->get('lib'),
5456
);
5457
return $exit_status;
5458
}
5459
elsif ( $o->get('stop') ) {
5460
stop_agent(
5461
pid_file => $o->get('pid'),
5462
lib_dir => $o->get('lib'),
5463
);
5464
$logger->info("Done stopping pt-agent, exit $exit_status");
5465
return $exit_status;
5466
}
5467
elsif ( my $n = $o->get('reset') ) {
5468
$exit_on_signals = 1;
5469
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";
5479
}
5480
else {
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";
5486
}
5487
}
5488
reset_agent(
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
5494
);
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.");
5498
}
5499
else {
5500
$logger->info("pt-agent has been completely reset.");
5501
}
5502
return $exit_status;
5503
}
5504
elsif ( $o->get('reload') ) {
5505
reload_agent(
5506
pid_file => $o->get('pid'),
5507
);
5508
return $exit_status;
5509
}
5510
5511
# ########################################################################
5512
# --ping and exit.
5513
# ########################################################################
5514
if ( $o->get('ping') ) {
5515
my ($client, $entry_links, $logger_client) = get_api_client(
5516
api_key => $api_key,
5517
tries => 1,
5518
interval => sub { return },
5519
);
5520
if ( !$client || !$entry_links ) {
5521
die "Failed to initialize the API client. The API may be down. Please try again.\n";
5522
}
5523
my $api_ok = ping_api(
5524
client => $client,
5525
);
5526
if ( $api_ok ) {
5527
print $client->{entry_link} . " is up.\n"
5528
}
5529
else {
5530
print $client->{entry_link} . " is down or not reachable.\n";
5531
}
5532
exit;
5533
}
5534
5535
# ########################################################################
5536
# --run-service and exit.
5537
# ########################################################################
5538
if ( my $service = $o->get('run-service') ) {
5539
eval {
5540
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'),
5546
Cxn => $cxn,
5547
);
5548
};
5549
if ( $EVAL_ERROR ) {
5550
$logger->fatal("--run-service $service error: $EVAL_ERROR");
5551
}
5552
return $exit_status;
5553
}
5554
5555
# ########################################################################
5556
# --send-data and exit.
5557
# ########################################################################
5558
if ( my $service = $o->get('send-data') ) {
5559
eval {
5560
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'),
5566
);
5567
};
5568
if ( $EVAL_ERROR ) {
5569
$logger->fatal("--send-data $service error: $EVAL_ERROR");
5570
}
5571
return $exit_status;
5572
}
5573
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
5578
# retried forever.
5579
# ########################################################################
5580
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
5586
# but don't create.
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")
5590
}
5591
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,
5598
Cxn => $cxn,
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
5604
);
5605
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;
5615
sleep $t;
5616
};
5617
5618
my $safeguards = Safeguards->new(
5619
disk_bytes_free => $o->get('disk-bytes-free'),
5620
disk_pct_free => $o->get('disk-pct-free'),
5621
);
5622
5623
# Run the agent's main loop which doesn't return until the service
5624
# is stopped, killed, or has an internal bug.
5625
eval {
5626
run_agent(
5627
agent => $running->{agent},
5628
client => $running->{client},
5629
daemon => $running->{daemon},
5630
interval => $interval,
5631
safeguards => $safeguards,
5632
Cxn => $cxn,
5633
lib_dir => $o->get('lib'),
5634
);
5635
};
5636
if ( $EVAL_ERROR ) {
5637
$logger->fatal("Error running agent: $EVAL_ERROR");
5638
}
5639
5640
$logger->info("pt-agent exit $exit_status, oktorun $oktorun");
5641
5642
return $exit_status;
5643
}
5644
5645
# ############################################################################
5646
# Subroutines
5647
# ############################################################################
5648
5649
# ################################################## #
5650
# Percona Web API subs for agent and spool processes #
5651
# ################################################## #
5652
5653
# Create and connect a Percona Web API client.
5654
sub get_api_client {
5655
my (%args) = @_;
5656
5657
have_required_args(\%args, qw(
5658
api_key
5659
interval
5660
)) or die;
5661
my $api_key = $args{api_key};
5662
my $interval = $args{interval};
5663
5664
# Optional args
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};
5669
5670
my $client = Percona::WebAPI::Client->new(
5671
api_key => $api_key,
5672
($entry_link ? (entry_link => $entry_link) : ()),
5673
);
5674
5675
my $entry_links;
5676
while ( $_oktorun->() && (!defined $tries || $tries--) ) {
5677
if ( !$state->{connecting_to_api}++ ) {
5678
$logger->debug("Connecting to Percona Web API") # once
5679
}
5680
eval {
5681
$entry_links = $client->get(link => $client->entry_link);
5682
};
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)");
5687
}
5688
else {
5689
$logger->info("API error: $e");
5690
}
5691
}
5692
elsif (
5693
!$entry_links
5694
|| (ref($entry_links) || '') ne 'HASH'
5695
|| !scalar keys %$entry_links
5696
) {
5697
$logger->info('API returned invalid entry links: '
5698
. Dumper($entry_links));
5699
}
5700
elsif ( !$entry_links->{agents} ) {
5701
$logger->info('API did not return agents link: '
5702
. Dumper($entry_links));
5703
}
5704
else {
5705
$logger->debug("Connected");
5706
delete $state->{connecting_to_api};
5707
last; # success
5708
}
5709
if (!defined $tries || $tries > 0) {
5710
$interval->(); # failure, try again
5711
}
5712
}
5713
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.
5720
my $logger_client;
5721
if ( $client && $entry_links ) {
5722
$logger_client = Percona::WebAPI::Client->new(
5723
api_key => $api_key,
5724
($entry_link ? (entry_link => $entry_link) : ()),
5725
);
5726
}
5727
5728
return $client, $entry_links, $logger_client;
5729
}
5730
5731
sub load_local_agent {
5732
my (%args) = @_;
5733
5734
have_required_args(\%args, qw(
5735
lib_dir
5736
)) or die;
5737
my $lib_dir = $args{lib_dir};
5738
5739
# Optional args
5740
my $agent_uuid = $args{agent_uuid};
5741
my $quiet = $args{quiet};
5742
5743
my $agent;
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.");
5751
}
5752
}
5753
else {
5754
$logger->debug("No local agent") unless $quiet;
5755
}
5756
5757
return $agent;
5758
}
5759
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.
5763
sub init_agent {
5764
my (%args) = @_;
5765
5766
have_required_args(\%args, qw(
5767
agent
5768
action
5769
link
5770
client
5771
tries
5772
interval
5773
)) or die;
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};
5780
5781
# Optional args
5782
my $_oktorun = $args{oktorun} || sub { return $oktorun };
5783
my $actions = $args{actions};
5784
my $quiet = $args{quiet};
5785
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);
5792
5793
# Try to create/update the Agent.
5794
my $success = 0;
5795
while ( $_oktorun->() && $tries-- ) {
5796
if ( !$state->{init_action}++ && !$quiet ) {
5797
$logger->info($action eq 'put' ? "Updating agent " . $agent->name
5798
: "Creating new agent");
5799
}
5800
my $agent_uri = eval {
5801
$client->$action(
5802
link => $link,
5803
resources => $agent,
5804
);
5805
};
5806
if ( $EVAL_ERROR ) {
5807
my $code = $client->response->code;
5808
if ( $code && $code == 404 ) {
5809
my $api_ok = ping_api(
5810
client => $client,
5811
);
5812
if ( $api_ok ) {
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.");
5817
}
5818
else {
5819
$logger->warning("API is down.");
5820
}
5821
}
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.");
5828
}
5829
}
5830
else {
5831
$logger->warning($EVAL_ERROR);
5832
}
5833
}
5834
elsif ( !$agent_uri ) {
5835
$logger->warning("No URI for Agent " . $agent->name);
5836
}
5837
else {
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.
5841
eval {
5842
$agent = $client->get(
5843
link => $agent_uri,
5844
);
5845
};
5846
if ( $EVAL_ERROR ) {
5847
$logger->warning($EVAL_ERROR);
5848
}
5849
else {
5850
$success = 1;
5851
last; # success
5852
}
5853
}
5854
if ( $tries > 0 ) {
5855
$interval->(); # failure, try again
5856
}
5857
}
5858
5859
delete $state->{init_action};
5860
delete $state->{too_many_agents};
5861
5862
return $agent, $success;
5863
}
5864
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,
5867
# /crontab.err).
5868
sub init_lib_dir {
5869
my (%args) = @_;
5870
have_required_args(\%args, qw(
5871
lib_dir
5872
)) or die;
5873
my $lib_dir = $args{lib_dir};
5874
5875
# Optiona args
5876
my $verify = $args{verify};
5877
my $quiet = $args{quiet};
5878
5879
$logger->info(($verify ? 'Verify' : 'Initializing') . " --lib $lib_dir")
5880
unless $quiet;
5881
5882
if ( ! -d $lib_dir ) {
5883
if ( $verify ) {
5884
die "$lib_dir does not exist\n";
5885
}
5886
else {
5887
$logger->info("$lib_dir does not exist, creating")
5888
unless $quiet;
5889
_safe_mkdir($lib_dir);
5890
}
5891
}
5892
elsif ( ! -w $lib_dir ) {
5893
die "--lib $lib_dir is not writable.\n";
5894
}
5895
5896
foreach my $dir ( qw(services logs pids meta) ) {
5897
my $dir = "$lib_dir/$dir";
5898
if ( ! -d $dir ) {
5899
if ( $verify ) {
5900
die "$dir does not exist\n";
5901
}
5902
else {
5903
$logger->info("$dir does not exist, creating")
5904
unless $quiet;
5905
_safe_mkdir($dir);
5906
}
5907
}
5908
elsif ( ! -w $dir ) {
5909
die "$dir is not writable.\n";
5910
}
5911
}
5912
5913
return;
5914
}
5915
5916
# ################################ #
5917
# Agent (main daemon) process subs #
5918
# ################################ #
5919
5920
sub start_agent {
5921
my (%args) = @_;
5922
5923
have_required_args(\%args, qw(
5924
api_key
5925
lib_dir
5926
Cxn
5927
)) or die;
5928
my $api_key = $args{api_key};
5929
my $lib_dir = $args{lib_dir};
5930
my $cxn = $args{Cxn};
5931
5932
# Optional args
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
5944
5945
# $logger->info('Starting agent');
5946
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:
5955
5956
--lib " . ($lib_dir || '') . "
5957
--log " . ($log_file || '') . "
5958
--pid " . ($pid_file || '') . "
5959
5960
These values can change if a different configuration is received.
5961
",
5962
}
5963
);
5964
$daemon->run();
5965
if ( $daemonize ) {
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.
5973
$cxn->{parent} = 0;
5974
}
5975
5976
# Make --lib and its subdirectories.
5977
eval {
5978
init_lib_dir(
5979
lib_dir => $lib_dir,
5980
);
5981
};
5982
if ( $EVAL_ERROR ) {
5983
chomp($EVAL_ERROR);
5984
$logger->info("Error initializing --lib $lib_dir: $EVAL_ERROR. "
5985
. "Configure the agent to use a writeable --lib directory.");
5986
}
5987
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,
5992
tries => $tries,
5993
interval => $interval,
5994
);
5995
}
5996
if ( !$client || !$entry_links ) {
5997
die "Failed to initialize the API client. The API may be down. Please try again.\n";
5998
}
5999
return unless $_oktorun->();
6000
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
6006
# it later.
6007
if ( !$versions || !$versions->{MySQL} ) {
6008
$versions = get_versions(
6009
Cxn => $cxn,
6010
);
6011
}
6012
return unless $_oktorun->();
6013
6014
# Load and update the local (i.e. existing) agent, or create a new one.
6015
my $agent;
6016
my $action;
6017
my $link;
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,
6023
);
6024
$action = 'put'; # update
6025
$link = $entry_links->{agents} . '/' . $agent->uuid;
6026
}
6027
else {
6028
# First try to load the local agent.
6029
$agent = load_local_agent(
6030
lib_dir => $lib_dir,
6031
);
6032
if ( $agent ) {
6033
# Loaded local agent.
6034
$action = 'put'; # update
6035
$link = $entry_links->{agents} . '/' . $agent->uuid;
6036
$agent->{versions} = $versions;
6037
}
6038
else {
6039
# No local agent and --agent-uuid wasn't give.
6040
$agent = Percona::WebAPI::Resource::Agent->new(
6041
versions => $versions,
6042
);
6043
$action = 'post'; # create
6044
$link = $entry_links->{agents};
6045
}
6046
}
6047
6048
my $success;
6049
($agent, $success) = init_agent(
6050
agent => $agent,
6051
action => $action, # put or post
6052
link => $link,
6053
client => $client,
6054
tries => $tries,
6055
interval => $interval,
6056
oktorun => $_oktorun, # optional
6057
);
6058
if ( !$success ) {
6059
die "Failed to initialize the agent. The API may be down. Please try again.\n";
6060
}
6061
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},
6070
);
6071
$logger->debug("Log API enabled");
6072
}
6073
6074
save_agent(
6075
agent => $agent,
6076
lib_dir => $lib_dir,
6077
);
6078
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");
6085
}
6086
else {
6087
$logger->warning("Cannot remove $service_file: $OS_ERROR");
6088
}
6089
}
6090
eval {
6091
schedule_services(
6092
services => [],
6093
lib_dir => $lib_dir,
6094
quiet => 1,
6095
);
6096
};
6097
if ( $EVAL_ERROR ) {
6098
$logger->error("Error removing services from crontab: $EVAL_ERROR");
6099
}
6100
6101
return {
6102
agent => $agent,
6103
client => $client,
6104
daemon => $daemon,
6105
};
6106
}
6107
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.
6110
sub run_agent {
6111
my (%args) = @_;
6112
6113
have_required_args(\%args, qw(
6114
agent
6115
client
6116
daemon
6117
interval
6118
lib_dir
6119
safeguards
6120
Cxn
6121
)) or die;
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};
6129
6130
# Optional args
6131
my $_oktorun = $args{oktorun} || sub { return $oktorun };
6132
6133
$logger->info('Running agent ' . $agent->name);
6134
6135
# #######################################################################
6136
# Main agent loop
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");
6144
6145
my $success;
6146
my $new_daemon;
6147
my $config;
6148
my $services = {};
6149
while ( $_oktorun->() ) {
6150
($config, $lib_dir, $new_daemon, $success) = get_config(
6151
link => $agent->links->{config},
6152
agent => $agent,
6153
client => $client,
6154
daemon => $daemon,
6155
lib_dir => $lib_dir,
6156
config => $config,
6157
quiet => $state->{first_config},
6158
);
6159
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};
6165
}
6166
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};
6178
}
6179
$daemon = $new_daemon;
6180
}
6181
6182
# Connect to MySQL, then check stuff.
6183
my $o = new OptionParser();
6184
$o->get_specs();
6185
$o->get_opts();
6186
my $dp = $o->DSNParser();
6187
$dp->prop('set-vars', $o->set_vars());
6188
my $dsn = $dp->parse_options($o);
6189
eval {
6190
$cxn->connect(dsn => $dsn);
6191
};
6192
if ( $EVAL_ERROR ) {
6193
if ( !$state->{mysql_error}++ ) {
6194
$logger->warning("MySQL connection failure: $EVAL_ERROR");
6195
}
6196
else {
6197
$logger->debug("MySQL connection failure: $EVAL_ERROR");
6198
}
6199
$state->{have_mysql} = 0;
6200
$state->{need_mysql_version} = 1;
6201
}
6202
else {
6203
if ( !$state->{have_mysql} ) {
6204
$logger->info("MySQL OK");
6205
}
6206
$state->{have_mysql} = 1;
6207
check_if_mysql_restarted(
6208
dbh => $cxn->dbh,
6209
);
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);
6215
my $updated_agent;
6216
($agent, $updated_agent) = init_agent(
6217
agent => $agent,
6218
action => 'put',
6219
link => $agent->links->{self},
6220
client => $client,
6221
tries => 1,
6222
interval => sub { return; },
6223
quiet => 1,
6224
);
6225
if ( $updated_agent ) {
6226
$logger->debug("Got MySQL version");
6227
save_agent(
6228
agent => $agent,
6229
lib_dir => $lib_dir,
6230
);
6231
if ( !$state->{ready} || $state->{mysql_error} ) {
6232
$logger->info('Agent OK');
6233
}
6234
delete $state->{need_mysql_version};
6235
delete $state->{mysql_error};
6236
$state->{ready} = 1;
6237
}
6238
}
6239
else {
6240
if ( !$state->{mysql_error}++ ) {
6241
$logger->warning("Failed to get MySQL version");
6242
}
6243
else {
6244
$logger->debug("Failed to get MySQL version");
6245
}
6246
}
6247
}
6248
$cxn->dbh->disconnect();
6249
}
6250
6251
# Check the safeguards.
6252
my ($disk_space, $disk_space_ok);
6253
eval {
6254
$disk_space = $safeguards->get_disk_space(
6255
filesystem => $config->options->{spool},
6256
);
6257
$disk_space_ok = $safeguards->check_disk_space(
6258
disk_space => $disk_space,
6259
);
6260
};
6261
if ( $EVAL_ERROR ) {
6262
$logger->error("Error checking disk space: $EVAL_ERROR");
6263
$disk_space_ok = 1;
6264
}
6265
if ( !$disk_space_ok ) {
6266
$logger->warning("Disk bytes free/percentage threshold: "
6267
. $safeguards->{disk_bytes_free}
6268
. '/'
6269
. $safeguards->{disk_pct_free});
6270
$logger->warning("Disk space is low, stopping all services:\n"
6271
. $disk_space);
6272
if ( !$state->{all_services_are_stopped} ) {
6273
stop_all_services(
6274
lib_dir => $lib_dir,
6275
);
6276
}
6277
$logger->warning('Services will restart when disk space "
6278
. "threshold checks pass');
6279
}
6280
elsif ( $state->{ready} ) {
6281
($services, $success) = get_services(
6282
link => $config->links->{services},
6283
agent => $agent,
6284
client => $client,
6285
lib_dir => $lib_dir,
6286
services => $services,
6287
json => $args{json}, # optional, for testing
6288
bin_dir => $args{bin_dir}, # optional, for testing
6289
);
6290
}
6291
}
6292
6293
# If configured, wait the given interval. Else, retry more
6294
# quickly so we're ready to go soon after we're configured.
6295
$interval->(
6296
!$state->{ready} ? (20, 1)
6297
: $config ? ($config->options->{'check-interval'}, 0)
6298
: ($first_config_interval , 1) # 1=quiet
6299
);
6300
}
6301
6302
stop_all_services(
6303
lib_dir => $lib_dir,
6304
);
6305
6306
# This shouldn't happen until the service is stopped/killed.
6307
$logger->info('Agent ' . $agent->name . ' has stopped');
6308
return;
6309
}
6310
6311
sub get_config {
6312
my (%args) = @_;
6313
have_required_args(\%args, qw(
6314
link
6315
agent
6316
client
6317
daemon
6318
lib_dir
6319
)) or die;
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};
6325
6326
# Optional args
6327
my $config = $args{config}; # may not be defined yet
6328
my $quiet = $args{quiet};
6329
6330
my $success = 0;
6331
my $new_daemon;
6332
6333
$logger->debug('Getting agent config') unless $quiet;
6334
my $new_config = eval {
6335
$client->get(
6336
link => $link,
6337
);
6338
};
6339
if ( my $e = $EVAL_ERROR ) {
6340
if (blessed($e)) {
6341
if ($e->isa('Percona::WebAPI::Exception::Request')) {
6342
if ( $e->status == 404 ) {
6343
my $api_ok = ping_api(
6344
client => $client,
6345
);
6346
if ( $api_ok ) {
6347
stop_all_services(
6348
lib_dir => $lib_dir,
6349
);
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.");
6354
}
6355
else {
6356
# offline warning
6357
$logger->_log(0, 'WARNING', "Cannot get agent config: API is down. "
6358
. "Will try again.");
6359
}
6360
}
6361
else {
6362
# offline warning
6363
$logger->_log(0, 'WARNING', "Cannot get agent config: API error: $e. "
6364
. "Will try again.")
6365
}
6366
}
6367
elsif ($e->isa('Percona::WebAPI::Exception::Resource')) {
6368
$logger->error("Invalid agent config: $e");
6369
}
6370
}
6371
else {
6372
$logger->error("Internal error getting agent config: $e");
6373
}
6374
}
6375
else {
6376
eval {
6377
if ( !$quiet ) {
6378
$logger->debug("Running config: " . ($config ? $config->ts : ''));
6379
$logger->debug("Current config: " . $new_config->ts);
6380
}
6381
if ( !$config || $new_config->ts > $config->ts ) {
6382
($lib_dir, $new_daemon) = apply_config(
6383
agent => $agent,
6384
old_config => $config,
6385
new_config => $new_config,
6386
lib_dir => $lib_dir,
6387
daemon => $daemon,
6388
);
6389
$config = $new_config;
6390
$success = 1;
6391
$logger->info('Config ' . $config->ts . ' applied');
6392
6393
$state->{need_mysql_version} = 1;
6394
}
6395
else {
6396
$success = 1;
6397
$logger->debug('Config has not changed') unless $quiet;
6398
}
6399
};
6400
if ( $EVAL_ERROR ) {
6401
chomp $EVAL_ERROR;
6402
$logger->warning("Failed to apply config " . $new_config->ts
6403
. ": $EVAL_ERROR Will try again.");
6404
}
6405
}
6406
6407
return ($config, $lib_dir, $new_daemon, $success);
6408
}
6409
6410
sub apply_config {
6411
my (%args) = @_;
6412
6413
have_required_args(\%args, qw(
6414
agent
6415
new_config
6416
lib_dir
6417
daemon
6418
)) or die;
6419
my $agent = $args{agent};
6420
my $new_config = $args{new_config};
6421
my $lib_dir = $args{lib_dir};
6422
my $daemon = $args{daemon};
6423
6424
# Optional args
6425
my $old_config = $args{old_config};
6426
6427
$logger->debug('Applying config ' . $new_config->ts);
6428
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");
6435
init_lib_dir(
6436
lib_dir => $new_lib_dir,
6437
);
6438
6439
# TODO: copy old-lib/services/* to new-lib/services/ ?
6440
6441
# Save agent as --lib/agent so next time the tool starts it
6442
# loads the agent from the latest --lib dir.
6443
save_agent(
6444
agent => $agent,
6445
lib_dir => $new_lib_dir,
6446
);
6447
}
6448
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.
6452
my $new_daemon;
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;
6462
}
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;
6469
}
6470
}
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(
6477
daemonize => 0,
6478
pid_file => $new_pid,
6479
log_file => $new_log,
6480
force_log_file => $daemon->{daemonize},
6481
);
6482
eval {
6483
$new_daemon->run();
6484
6485
if ( $daemon->{daemonize} && $old_log ne $new_log ) {
6486
$logger->info('New log file, previous was '
6487
. ($old_log || 'unset'));
6488
}
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
6496
# away.
6497
$new_daemon->{sharing_pid_file} = 1;
6498
}
6499
};
6500
if ( $EVAL_ERROR ) {
6501
die "Error changing --pid and/or --log: $EVAL_ERROR\n";
6502
}
6503
}
6504
6505
# Save config in $HOME/.pt-agent.conf if successful.
6506
write_config(
6507
config => $new_config,
6508
);
6509
6510
return ($new_lib_dir || $lib_dir), $new_daemon;
6511
}
6512
6513
# Write a Config resource to a Percona Toolkit config file,
6514
# usually $HOME/pt-agent.conf.
6515
sub write_config {
6516
my (%args) = @_;
6517
6518
have_required_args(\%args, qw(
6519
config
6520
)) or die;
6521
my $config = $args{config};
6522
6523
my $file = get_config_file();
6524
$logger->info("Writing config to $file");
6525
6526
# Get the api-key line if any; we don't want to/can't clobber this.
6527
my $api_key;
6528
my $no_log_api;
6529
if ( -f $file ) {
6530
open my $fh, "<", $file
6531
or die "Error opening $file: $OS_ERROR";
6532
my $contents = do { local $/ = undef; <$fh> };
6533
close $fh;
6534
($api_key) = $contents =~ m/^(api-key=\S+)$/m;
6535
($no_log_api) = $contents =~ m/^(no-log-api)$/m;
6536
}
6537
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";
6541
if ( $api_key ) {
6542
print { $fh } $api_key, "\n"
6543
or die "Error writing to $file: $OS_ERROR";
6544
}
6545
if ( $no_log_api ) {
6546
print { $fh } $no_log_api, "\n"
6547
or die "Error writing to $file: $OS_ERROR";
6548
}
6549
print { $fh } as_config($config)
6550
or die "Error writing to $file: $OS_ERROR";
6551
close $fh
6552
or die "Error closing $file: $OS_ERROR";
6553
6554
return;
6555
}
6556
6557
sub get_services {
6558
my (%args) = @_;
6559
have_required_args(\%args, qw(
6560
link
6561
agent
6562
client
6563
lib_dir
6564
services
6565
)) or die;
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};
6571
6572
my $success = 0;
6573
6574
eval {
6575
$logger->debug('Getting services');
6576
my $curr_services = $client->get(
6577
link => $link,
6578
);
6579
6580
if ( !$curr_services ) {
6581
$logger->error("GET $link did not return anything, "
6582
. "expected a list of services");
6583
}
6584
elsif ( !scalar @$curr_services && !scalar keys %$prev_services ) {
6585
$logger->debug("No services are enabled for this agent");
6586
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};
6592
}
6593
if ( $state->{all_services_are_stopped} ) {
6594
delete $state->{all_services_are_stopped};
6595
}
6596
}
6597
else {
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};
6607
}
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};
6614
}
6615
6616
# Determine which services are new (added), changed/updated,
6617
# and removed.
6618
my $sorted_services = sort_services(
6619
prev_services => $prev_services,
6620
curr_services => $curr_services,
6621
);
6622
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(
6628
action => 'stop',
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
6633
);
6634
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.
6639
write_services(
6640
sorted_services => $sorted_services,
6641
lib_dir => $lib_dir,
6642
json => $args{json}, # optional, for testing
6643
);
6644
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.
6649
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
6659
);
6660
6661
# Start new services.
6662
my $started_ok = apply_services(
6663
action => 'start',
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
6668
);
6669
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
6677
);
6678
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 )
6688
{
6689
schedule_services(
6690
services => [
6691
@$started_ok,
6692
@$restarted_ok,
6693
@{$sorted_services->{unchanged}},
6694
],
6695
lib_dir => $lib_dir,
6696
bin_dir => $args{bin_dir}, # optional, for testing
6697
exec_cmd => $args{exec_cmd}, # optional, for testing
6698
);
6699
6700
$logger->info('Services OK');
6701
}
6702
else {
6703
$logger->debug('Services have not changed');
6704
}
6705
# TODO: probably shouldn't keep re-assigning this unless necessary
6706
$prev_services = $sorted_services->{services};
6707
$success = 1;
6708
}
6709
};
6710
if ( $EVAL_ERROR ) {
6711
$logger->warning($EVAL_ERROR);
6712
}
6713
6714
return $prev_services, $success;
6715
}
6716
6717
sub sort_services {
6718
my (%args) = @_;
6719
6720
have_required_args(\%args, qw(
6721
prev_services
6722
curr_services
6723
)) or die;
6724
my $prev_services = $args{prev_services}; # hashref
6725
my $curr_services = $args{curr_services}; # arrayref
6726
6727
my $services = {}; # curr_services as hashref keyed on service name
6728
my @added;
6729
my @updated;
6730
my @removed;
6731
my @unchanged;
6732
6733
foreach my $service ( @$curr_services ) {
6734
my $name = $service->name;
6735
$services->{$name} = $service;
6736
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/.
6741
6742
if ( !exists $prev_services->{$name} ) {
6743
push @added, $service;
6744
}
6745
elsif ( $service->ts > $prev_services->{$name}->ts ) {
6746
push @updated, $service;
6747
}
6748
else {
6749
push @unchanged, $service;
6750
}
6751
}
6752
if ( scalar keys %$prev_services ) {
6753
@removed = grep { !exists $services->{$_->name} } values %$prev_services;
6754
}
6755
6756
if ( scalar @added ) {
6757
$logger->info("Added services: "
6758
. join(', ', map { $_->name } @added));
6759
}
6760
if ( scalar @updated ) {
6761
$logger->info("Services updated: "
6762
. join(', ', map { $_->name } @updated));
6763
}
6764
if ( scalar @removed ) {
6765
$logger->info("Services removed: "
6766
. join(', ', map { $_->name } @removed));
6767
}
6768
6769
my $sorted_services = {
6770
services => $services,
6771
added => \@added,
6772
updated => \@updated,
6773
removed => \@removed,
6774
unchanged => \@unchanged,
6775
};
6776
return $sorted_services;
6777
}
6778
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 {
6782
my (%args) = @_;
6783
6784
have_required_args(\%args, qw(
6785
sorted_services
6786
lib_dir
6787
)) or die;
6788
my $sorted_services = $args{sorted_services};
6789
my $lib_dir = $args{lib_dir};
6790
6791
# Optional args
6792
my $json = $args{json}; # for testing
6793
6794
$lib_dir .= '/services';
6795
6796
$logger->debug("Writing services to $lib_dir");
6797
6798
# Save current, active services.
6799
foreach my $service (
6800
@{$sorted_services->{added}}, @{$sorted_services->{updated}}
6801
) {
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";
6808
close $fh
6809
or die "Error closing $file: $OS_ERROR";
6810
$logger->info("$action $file");
6811
}
6812
6813
# Remove old services.
6814
foreach my $service ( @{$sorted_services->{removed}} ) {
6815
my $file = $lib_dir . '/' . $service->name;
6816
if ( -f $file ) {
6817
unlink $file
6818
or die "Error removing $file: $OS_ERROR";
6819
$logger->info("Removed $file");
6820
}
6821
}
6822
6823
return;
6824
}
6825
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 {
6829
my (%args) = @_;
6830
6831
have_required_args(\%args, qw(
6832
services
6833
lib_dir
6834
)) or die;
6835
my $services = $args{services};
6836
my $lib_dir = $args{lib_dir};
6837
6838
# Optional args
6839
my $quiet = $args{quiet};
6840
my $exec_cmd = $args{exec_cmd} || sub { return system(@_) };
6841
6842
$logger->info("Scheduling services") unless $quiet;
6843
6844
# Only schedule "periodic" services, i.e. ones that run periodically,
6845
# not just once.
6846
my @periodic_services = grep { $_->run_schedule || $_->spool_schedule }
6847
@$services;
6848
my $new_crontab = make_new_crontab(
6849
%args,
6850
services => \@periodic_services,
6851
);
6852
$logger->info("New crontab:\n" . $new_crontab || '') unless $quiet;
6853
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";
6859
close $fh
6860
or die "Error closing $crontab_file: $OS_ERROR";
6861
6862
my $err_file = "$lib_dir/crontab.err";
6863
my $retval = $exec_cmd->("crontab $crontab_file > $err_file 2>&1");
6864
if ( $retval ) {
6865
my $error = -f $err_file ? `cat $err_file` : '';
6866
die "Error setting new crontab: $error";
6867
}
6868
6869
return;
6870
}
6871
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
6874
# crontab lines.
6875
sub make_new_crontab {
6876
my (%args) = @_;
6877
6878
have_required_args(\%args, qw(
6879
services
6880
)) or die;
6881
my $services = $args{services};
6882
6883
# Optional args
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}
6887
: "$FindBin::Bin/";
6888
6889
my @other_lines
6890
= grep { $_ !~ m/pt-agent (?:--run-service|--send-data)/ }
6891
split("\n", $crontab_list);
6892
PTDEBUG && _d('Other crontab lines:', Dumper(\@other_lines));
6893
6894
my $env_vars = env_vars();
6895
6896
my @pt_agent_lines;
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 "
6903
. $service->name;
6904
}
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 "
6910
. $service->name;
6911
}
6912
}
6913
PTDEBUG && _d('pt-agent crontab lines:', Dumper(\@pt_agent_lines));
6914
6915
my $new_crontab = join("\n", @other_lines, @pt_agent_lines) . "\n";
6916
$logger->debug("New crontab: " . ($new_crontab || ''));
6917
6918
return $new_crontab;
6919
}
6920
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 {
6928
my (%args) = @_;
6929
have_required_args(\%args, qw(
6930
action
6931
services
6932
lib_dir
6933
)) or die;
6934
my $action = $args{action};
6935
my $services = $args{services};
6936
my $lib_dir = $args{lib_dir};
6937
6938
# Optional args
6939
my $bin_dir = defined $args{bin_dir} ? "$args{bin_dir}"
6940
: "$FindBin::Bin/";
6941
my $exec_cmd = $args{exec_cmd} || sub { return system(@_) };
6942
6943
$bin_dir .= '/' unless $bin_dir =~ m/\/$/;
6944
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";
6949
6950
my @applied_ok;
6951
SERVICE:
6952
foreach my $service ( @$services ) {
6953
next if $service->meta; # only real services
6954
6955
my $name = $service->name;
6956
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;
6967
}
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).
6977
next SERVICE;
6978
}
6979
}
6980
}
6981
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");
6992
}
6993
else {
6994
$logger->warning("Cannot remove $meta_file: $OS_ERROR");
6995
}
6996
}
6997
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");
7009
next SERVICE;
7010
}
7011
push @applied_ok, $service;
7012
$logger->info("Started $name");
7013
}
7014
}
7015
}
7016
7017
return \@applied_ok;
7018
}
7019
7020
sub apply_services_once {
7021
my (%args) = @_;
7022
have_required_args(\%args, qw(
7023
services
7024
lib_dir
7025
)) or die;
7026
my $services = $args{services};
7027
my $lib_dir = $args{lib_dir};
7028
7029
# Optional args
7030
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir}
7031
: "$FindBin::Bin/";
7032
my $exec_cmd = $args{exec_cmd} || sub { return system(@_) };
7033
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";
7038
7039
my @ran_ok;
7040
SERVICE:
7041
foreach my $name ( sort keys %$services ) {
7042
my $service = $services->{$name};
7043
next unless $service->run_once;
7044
7045
delete $services->{$name};
7046
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");
7053
next SERVICE;
7054
}
7055
push @ran_ok, $service;
7056
$logger->info("Ran $name");
7057
}
7058
7059
return \@ran_ok;
7060
}
7061
7062
# ########################## #
7063
# --run-service process subs #
7064
# ########################## #
7065
7066
sub run_service {
7067
my (%args) = @_;
7068
7069
have_required_args(\%args, qw(
7070
api_key
7071
service
7072
lib_dir
7073
spool_dir
7074
Cxn
7075
)) or die;
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};
7081
7082
# Optional args
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;
7091
7092
my $start_time = time;
7093
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.
7096
init_lib_dir(
7097
lib_dir => $lib_dir,
7098
verify => 1, # die unless ok, don't create
7099
quiet => 1,
7100
);
7101
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,
7107
);
7108
my $service_name = $service->name;
7109
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,
7115
);
7116
$daemon->run();
7117
7118
if ( $service->meta ) {
7119
$logger->service($service_name);
7120
}
7121
else {
7122
$logger->service("$service_name run");
7123
}
7124
$logger->info("Running $service_name");
7125
7126
# Connect to Percona, get entry links.
7127
my $logger_client;
7128
if ( $agent_api && (!$client || !$entry_links) ) {
7129
($client, $entry_links, $logger_client) = get_api_client(
7130
api_key => $api_key,
7131
tries => 2,
7132
interval => sub { return 2; },
7133
);
7134
if ( !$client || !$entry_links ) {
7135
# offline warning
7136
$logger->_log(0, 'WARNING', "Failed to connect to Percona Web API");
7137
}
7138
}
7139
7140
# Load and update the local (i.e. existing) agent, or create a new one.
7141
if ( !$agent ) {
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,
7148
);
7149
if ( !$agent ) {
7150
$logger->fatal("No agent exists ($lib_dir/agent) and --agent-uuid was "
7151
. "not specified. Check that the agent is properly installed.");
7152
}
7153
}
7154
7155
# Start online logging, if possible.
7156
if ( $logger->online_logging && $agent_api && $client && $entry_links && $entry_links->{agents} ) {
7157
$agent = eval {
7158
$client->get(
7159
link => $entry_links->{agents} . '/' . $agent->uuid,
7160
);
7161
};
7162
if ( $EVAL_ERROR ) {
7163
$logger->info("Failed to get agent for online logging: $EVAL_ERROR");
7164
}
7165
else {
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,
7171
);
7172
$logger->debug("Log API enabled");
7173
}
7174
}
7175
else {
7176
$logger->_log(0, 'INFO', "File logging only");
7177
}
7178
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;
7183
my $use_spool = 0;
7184
my $use_mysql = 0;
7185
foreach my $task ( @$tasks ) {
7186
$use_spool = 1 if ($task->output || '') eq 'spool';
7187
$use_mysql = 1 if $task->query;
7188
}
7189
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,
7195
);
7196
7197
# Connect to MySQL or quit.
7198
my $last_error;
7199
if ( $use_mysql ) {
7200
$logger->debug("Connecting to MySQL");
7201
TRY:
7202
for ( 1..2 ) {
7203
eval {
7204
$cxn->connect();
7205
};
7206
if ( my $e = $EVAL_ERROR ) {
7207
$logger->debug("Cannot connect to MySQL: $e");
7208
$last_error = $e;
7209
sleep(3);
7210
next TRY;
7211
}
7212
last TRY;
7213
}
7214
if ( !$cxn->dbh ) {
7215
$logger->error("Cannot run " . $service->name . " because it requires "
7216
. "MySQL but failed to connect to MySQL: " . ($last_error || '(no error)'));
7217
return;
7218
}
7219
}
7220
7221
# Run the tasks, spool any data.
7222
my @output_files;
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";
7226
my $taskno = 0;
7227
my $metadata = { data_ts => $prefix };
7228
my $store = {};
7229
my $env_vars = env_vars();
7230
7231
TASK:
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."
7243
. $service->name
7244
. ".output.$taskno";
7245
my $append = 0;
7246
my $output_file;
7247
my $join_char;
7248
my ($store_key, $store_key_value_tuple);
7249
7250
my $output = $task->output || '';
7251
if ( $output eq 'spool' ) {
7252
$output_file = $tmp_data_file;
7253
}
7254
elsif ( $output =~ m/^stage:(\S+)/ ) {
7255
my $file_suffix = $1;
7256
$output_file = "$tmp_dir/$prefix." . $service->name . "$file_suffix";
7257
}
7258
elsif ( $output =~ m/^meta:(\S+)/ ) {
7259
my $attrib = $1;
7260
$output_file = "$lib_dir/meta/" . $service->name . ".meta.$attrib";
7261
}
7262
elsif ( $output =~ m/^join:(.)$/ ) {
7263
$join_char = $1;
7264
$output_file = $task_output_file;
7265
}
7266
elsif ( $output =~ m/store:key:([\w-]+)/ ) {
7267
$store_key = $1;
7268
$output_file = $task_output_file;
7269
}
7270
elsif ( $output eq 'store:output' ) {
7271
$store_key = $taskno;
7272
$output_file = $task_output_file;
7273
}
7274
elsif ( $output eq 'store:key_value_tuple' ) {
7275
$store_key_value_tuple = 1;
7276
}
7277
elsif ( $output eq 'store:output' ) {
7278
$store_key = $taskno;
7279
$output_file = $task_output_file;
7280
}
7281
elsif ( $output =~ m/append:(\S+)/ ) {
7282
$output_file = $1;
7283
$append = 1;
7284
}
7285
elsif ( $output eq 'tmp' ) {
7286
$output_file = $task_output_file;
7287
}
7288
7289
if ( !$output_file ) {
7290
$output_file = '/dev/null';
7291
push @output_files, undef,
7292
}
7293
else {
7294
push @output_files, $output_file;
7295
}
7296
PTDEBUG && _d("Task $taskno output:", Dumper(\@output_files));
7297
7298
if ( my $query = $task->query ) {
7299
$query = replace_special_vars(
7300
cmd => $query,
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__
7311
);
7312
$logger->info($task->name . ": $query");
7313
my $rows;
7314
my $t0 = time;
7315
eval {
7316
if ( $join_char || $store_key_value_tuple ) {
7317
$rows = $cxn->dbh->selectall_arrayref($query);
7318
}
7319
else {
7320
$cxn->dbh->do($query);
7321
}
7322
};
7323
if ( $EVAL_ERROR ) {
7324
$logger->error("Error executing $query: $EVAL_ERROR");
7325
last TASK;
7326
}
7327
7328
if ( $rows ) {
7329
$logger->debug('Query returned ' . scalar @$rows . ' rows');
7330
if ( $join_char ) {
7331
my $fh;
7332
if ( !open($fh, '>', $output_file) ) {
7333
$logger->error("Cannot open $output_file: $OS_ERROR");
7334
last TASK;
7335
}
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");
7340
}
7341
close $fh
7342
or $logger->warning("Cannot close $output_file: $OS_ERROR");
7343
}
7344
elsif ( $store_key_value_tuple ) {
7345
foreach my $row ( @$rows ) {
7346
$store->{$row->[0]} = defined $row->[1] ? $row->[1] : 'NULL';
7347
}
7348
}
7349
}
7350
my $t1 = time;
7351
7352
push @{$metadata->{tasks}}, {
7353
start_ts => ts($t0, 1),
7354
end_ts => ts($t1, 1),
7355
run_time => sprintf('%.6f', $t1 - $t0),
7356
};
7357
}
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.
7361
my $cmd = join(' ',
7362
$task->program,
7363
($append ? '>>' : '>'),
7364
$output_file,
7365
);
7366
$cmd = replace_special_vars(
7367
cmd => $cmd,
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__
7378
);
7379
$logger->debug("Task $taskno command: $cmd");
7380
7381
if ( $cmd =~ m/$recursive_service/ ) {
7382
$logger->fatal("Recursive service detected: $cmd");
7383
die; # fatal() should die, but just in case
7384
}
7385
7386
# Execute this run.
7387
my $t0 = time;
7388
system($cmd);
7389
if ( $store_key ) {
7390
my $value = slurp($output_file);
7391
chomp($value) if $value;
7392
$store->{$store_key} = $value;
7393
}
7394
my $t1 = time;
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;
7399
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,
7405
};
7406
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.
7410
}
7411
elsif ( $cmd_exit_status == 253 ) {
7412
$logger->error($task->name . ' exit status not zero, '
7413
. 'stopping ' . $service->name . ' service');
7414
stop_service(
7415
service => $service->name,
7416
lib_dir => $lib_dir,
7417
);
7418
last TASK;
7419
}
7420
elsif ( $cmd_exit_status == 254 ) {
7421
$logger->error($task->name . ' exit status not zero, '
7422
. 'stopping all services');
7423
stop_all_services(
7424
lib_dir => $lib_dir
7425
);
7426
last TASK;
7427
}
7428
elsif ( $cmd_exit_status != 0 ) {
7429
$logger->info($task->name . ' exit status not zero, '
7430
. 'stopping tasks');
7431
last TASK;
7432
}
7433
}
7434
else {
7435
$logger->error('Invalid Task resource:', Dumper($task));
7436
last TASK;
7437
}
7438
7439
$taskno++;
7440
}
7441
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.)
7455
read_metadata(
7456
service => $service->name,
7457
prefix => $prefix,
7458
metadata => $metadata,
7459
stage_dir => $tmp_dir,
7460
);
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);
7464
write_to_file(
7465
data => $json_metadata,
7466
file => "$data_dir/$meta_file",
7467
);
7468
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);
7477
system($cmd);
7478
my $cmd_exit_status = $CHILD_ERROR >> 8;
7479
if ( $cmd_exit_status != 0 ) {
7480
$logger->error("Move failed: $cmd")
7481
}
7482
$exit_status |= $cmd_exit_status;
7483
}
7484
else {
7485
$logger->error("Data file is larger than $max_data, skipping: "
7486
. ($json_metadata || ''));
7487
}
7488
}
7489
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 . ".*" ) {
7493
unlink $file
7494
or $logger->warning("Error removing $file: $OS_ERROR");
7495
}
7496
7497
$logger->info("Exit: $exit_status");
7498
return $exit_status; # returning global var for testing
7499
}
7500
7501
sub load_service {
7502
my (%args) = @_;
7503
7504
have_required_args(\%args, qw(
7505
service
7506
lib_dir
7507
)) or die;
7508
my $service = $args{service};
7509
my $lib_dir = $args{lib_dir};
7510
7511
my $service_file = "$lib_dir/services/$service";
7512
if ( ! -f $service_file ) {
7513
$logger->fatal("Cannot load $service: $service_file does not exist.");
7514
}
7515
7516
my $service_obj;
7517
eval {
7518
my $service_hash = JSON::decode_json(slurp($service_file));
7519
$service_obj = Percona::WebAPI::Resource::Service->new(%$service_hash);
7520
};
7521
if ( $EVAL_ERROR ) {
7522
$logger->fatal("Cannot load $service: $EVAL_ERROR");
7523
}
7524
7525
return $service_obj;
7526
}
7527
7528
sub replace_special_vars {
7529
my (%args) = @_;
7530
7531
have_required_args(\%args, qw(
7532
cmd
7533
spool_dir
7534
output_files
7535
service
7536
lib_dir
7537
meta_dir
7538
stage_dir
7539
store
7540
ts
7541
bin_dir
7542
)) or die;
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};
7551
my $ts = $args{ts};
7552
my $bin_dir = $args{bin_dir};
7553
7554
# Optional args
7555
my $env = $args{env} || '';
7556
7557
my $word;
7558
my $new_cmd;
7559
eval {
7560
$new_cmd = join(' ',
7561
map {
7562
$word = $_;
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;
7575
$word;
7576
}
7577
split(/\s+/, $cmd)
7578
);
7579
};
7580
if ( $EVAL_ERROR ) {
7581
$logger->fatal("Error replacing " . ($word || '')
7582
. " in $cmd: $EVAL_ERROR");
7583
}
7584
7585
return $new_cmd;
7586
}
7587
7588
sub init_spool_dir {
7589
my (%args) = @_;
7590
7591
have_required_args(\%args, qw(
7592
spool_dir
7593
)) or die;
7594
my $spool_dir = $args{spool_dir};
7595
7596
# Optional args
7597
my $service = $args{service};
7598
my $quiet = $args{quiet};
7599
7600
if ( !-d $spool_dir ) {
7601
$logger->info("$spool_dir does not exist, creating")
7602
unless $quiet;
7603
_safe_mkdir($spool_dir);
7604
}
7605
elsif ( !-w $spool_dir ) {
7606
die "$spool_dir is not writeable\n";
7607
}
7608
7609
foreach my $subdir ( $service, '.tmp', '.trash' ) {
7610
next unless $subdir; # service may be undef
7611
my $dir = "$spool_dir/$subdir";
7612
if ( ! -d $dir ) {
7613
$logger->info("$dir does not exist, creating")
7614
unless $quiet;
7615
_safe_mkdir($dir);
7616
}
7617
elsif ( !-w $dir ) {
7618
die "$dir is not writeable\n";
7619
}
7620
}
7621
7622
my $data_dir = $service ? "$spool_dir/$service" : undef;
7623
my $tmp_dir = "$spool_dir/.tmp";
7624
7625
return $data_dir, $tmp_dir;
7626
}
7627
7628
sub read_metadata {
7629
my (%args) = @_;
7630
7631
have_required_args(\%args, qw(
7632
service
7633
prefix
7634
metadata
7635
stage_dir
7636
)) or die;
7637
my $service = $args{service};
7638
my $prefix = $args{prefix};
7639
my $metadata = $args{metadata};
7640
my $stage_dir = $args{stage_dir};
7641
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;
7650
unlink $file
7651
or $logger->warning("Cannot rm $file: $OS_ERROR");
7652
}
7653
7654
return;
7655
}
7656
7657
# ######################## #
7658
# --send-data process subs #
7659
# ######################## #
7660
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().
7664
sub send_data {
7665
my (%args) = @_;
7666
7667
have_required_args(\%args, qw(
7668
api_key
7669
service
7670
lib_dir
7671
spool_dir
7672
)) or die;
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};
7677
7678
# Optional args
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
7686
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.
7689
init_lib_dir(
7690
lib_dir => $lib_dir,
7691
verify => 1,
7692
quiet => 1,
7693
);
7694
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,
7700
);
7701
my $service_name = $service->name;
7702
7703
my ($service_dir) = init_spool_dir(
7704
spool_dir => $spool_dir,
7705
service => $service->name,
7706
);
7707
7708
my @data_files = glob "$service_dir/*.data";
7709
if ( scalar @data_files == 0 ) {
7710
$logger->debug("No $service_name data files to send");
7711
return;
7712
}
7713
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,
7720
);
7721
$daemon->run();
7722
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;
7727
7728
$logger->service("$service_name send");
7729
my $data_link = $service->links->{data};
7730
$logger->info("Sending " . scalar @data_files . " data files ($data_link)");
7731
7732
# Connect to Percona, get entry links.
7733
my $logger_client;
7734
if ( !$client || !$entry_links ) {
7735
($client, $entry_links, $logger_client) = get_api_client(
7736
api_key => $api_key,
7737
tries => 3,
7738
interval => sub { sleep 10 },
7739
);
7740
if ( !$client || !$entry_links ) {
7741
$logger->fatal("Failed to connect to Percona Web API")
7742
}
7743
}
7744
7745
# Load and update the local (i.e. existing) agent, or create a new one.
7746
if ( !$agent ) {
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,
7753
);
7754
if ( !$agent ) {
7755
$logger->fatal("No agent exists ($lib_dir/agent) and --agent-uuid was "
7756
. "not specified. Check that the agent is properly installed.");
7757
}
7758
}
7759
7760
$agent = eval {
7761
$client->get(
7762
link => $entry_links->{agents} . '/' . $agent->uuid,
7763
);
7764
};
7765
if ( $EVAL_ERROR ) {
7766
$logger->fatal("Failed to get the agent: $EVAL_ERROR");
7767
}
7768
my $log_link = $agent->links->{log};
7769
if ( $log_link ) {
7770
$logger->start_online_logging(
7771
client => $logger_client,
7772
log_link => $log_link,
7773
);
7774
$logger->debug("Log API enabled");
7775
}
7776
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().
7781
DATA_FILE:
7782
foreach my $data_file ( @data_files ) {
7783
(my $meta_file = $data_file) =~ s/\.data/.meta/;
7784
7785
if ( $interactive ) {
7786
my $key;
7787
PROMPT:
7788
while ( !$key ) {
7789
print "\n", `ls -l $data_file`;
7790
print "Send [Ynaq]: ";
7791
$key = <STDIN>;
7792
chomp($key);
7793
$key = lc($key);
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";
7799
$interactive = 0;
7800
last PROMPT;
7801
}
7802
warn "Invalid response: $key\n";
7803
}
7804
}
7805
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.");
7812
next DATA_FILE;
7813
}
7814
7815
eval {
7816
# Send the file as-is. The --run-service process should
7817
# have written the data in a format that's ready to send.
7818
send_file(
7819
client => $client,
7820
agent => $agent,
7821
meta_file => $meta_file,
7822
data_file => $data_file,
7823
link => $data_link,
7824
json => $json,
7825
);
7826
};
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)'));
7832
}
7833
else {
7834
chomp $e;
7835
$logger->warning("Error sending $data_file ($data_file_size bytes): $e");
7836
}
7837
next DATA_FILE;
7838
}
7839
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.
7845
eval {
7846
unlink $data_file or die $OS_ERROR;
7847
};
7848
if ( $EVAL_ERROR ) {
7849
chomp $EVAL_ERROR;
7850
$logger->warning("Sent $data_file but failed to remove it: "
7851
. $EVAL_ERROR);
7852
last DATA_FILE;
7853
}
7854
7855
if ( -f $meta_file ) {
7856
unlink $meta_file or $logger->warning($OS_ERROR);
7857
}
7858
7859
$logger->info("Sent: $data_file ($data_file_size bytes)");
7860
}
7861
7862
$logger->info("Exit: $exit_status");
7863
return $exit_status; # returning global var for testing
7864
}
7865
7866
# Send the Agent and file's contents as-is as a multi-part POST.
7867
sub send_file {
7868
my (%args) = @_;
7869
7870
have_required_args(\%args, qw(
7871
client
7872
agent
7873
data_file
7874
link
7875
)) or die;
7876
my $client = $args{client};
7877
my $agent = $args{agent};
7878
my $data_file = $args{data_file};
7879
my $link = $args{link};
7880
7881
# Optional args
7882
my $meta_file = $args{meta_file};
7883
my $json = $args{json}; # for testing
7884
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 =
7892
7893
my $agent_json = as_json($agent, json => $json);
7894
chomp($agent_json);
7895
7896
my $meta = -f $meta_file && -s $meta_file ? slurp($meta_file) : '';
7897
$meta =~ s/^\s+//;
7898
$meta =~ s/\s+$//;
7899
7900
my $data = -s $data_file ? slurp($data_file) : '';
7901
$data =~ s/^\s+//;
7902
$data =~ s/\s+$//;
7903
7904
# Put it all together:
7905
my $resource = <<CONTENT;
7906
--$boundary
7907
Content-Disposition: form-data; name="agent"
7908
7909
$agent_json
7910
--$boundary
7911
Content-Disposition: form-data; name="meta"
7912
7913
$meta
7914
--$boundary
7915
Content-Disposition: form-data; name="data"
7916
7917
$data
7918
--$boundary
7919
CONTENT
7920
7921
# This will die if the server response isn't 2xx or 3xx. The caller,
7922
# send_data(), should catch this.
7923
$client->post(
7924
link => $link,
7925
resources => $resource,
7926
headers => {
7927
'Content-Type' => "multipart/form-data; boundary=$boundary",
7928
}
7929
);
7930
7931
return;
7932
}
7933
7934
# ############################################ #
7935
# --status, --stop, --reload, and --reset subs #
7936
# ############################################ #
7937
7938
sub agent_status {
7939
my (%args) = @_;
7940
7941
have_required_args(\%args, qw(
7942
pid_file
7943
lib_dir
7944
)) or die;
7945
my $pid_file = $args{pid_file};
7946
my $lib_dir = $args{lib_dir};
7947
7948
# Optional args
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}
7953
: "$FindBin::Bin/";
7954
7955
# Check if pt-agent is running.
7956
my $pid = eval {
7957
get_agent_pid(
7958
pid_file => $pid_file,
7959
);
7960
};
7961
if ( my $e = $EVAL_ERROR ) {
7962
if ( !blessed($e) ) {
7963
$logger->warning("Sorry, an error occured while getting the pt-agent PID: $e");
7964
}
7965
elsif ( $e->isa('Percona::Agent::Exception::PIDNotFound') ) {
7966
$logger->info("pt-agent is not running");
7967
}
7968
elsif ( $e->isa('Percona::Agent::Exception::PIDNotRunning') ) {
7969
$logger->warning("$e. pt-agent may have stopped unexpectedly or crashed.");
7970
}
7971
else { # unhandled exception
7972
$logger->warning("Sorry, an unknown exception occured while getting "
7973
. "the pt-agent PID: $e");
7974
}
7975
}
7976
else {
7977
$logger->info("pt-agent is running as PID $pid")
7978
}
7979
7980
if ( $api_key ) {
7981
$logger->info("API key: " . ($api_key || ''));
7982
}
7983
else {
7984
$logger->warning("No API key is set");
7985
}
7986
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} || ''));
7992
}
7993
}
7994
else {
7995
$logger->warning("$lib_dir/agent does not exist");
7996
}
7997
7998
# Parse pt-agent lines from crontab to see what's scheduled/running.
7999
my %scheduled = map {
8000
my $line = $_;
8001
my ($service) = $line =~ m/pt-agent (?:--run-service|--send-data) (\S+)/;
8002
$service => 1;
8003
}
8004
grep { $_ =~ m/pt-agent (?:--run-service|--send-data)/ }
8005
split("\n", $crontab_list);
8006
8007
my %have_service;
8008
if ( -d "$lib_dir/services" ) {
8009
SERVICE:
8010
foreach my $service_file ( glob "$lib_dir/services/*" ) {
8011
my $service = eval {
8012
JSON::decode_json(slurp($service_file));
8013
};
8014
if ( $EVAL_ERROR ) {
8015
$logger->warning("$service_file is corrupt");
8016
next SERVICE;
8017
}
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} ) {
8022
if ( $pid ) {
8023
$logger->info($service->name . " is running");
8024
}
8025
else {
8026
$logger->warning($service->name . " is running but pt-agent is not");
8027
}
8028
}
8029
else {
8030
if ( $pid ) {
8031
$logger->warning($service->name . " is not running");
8032
}
8033
else {
8034
$logger->info($service->name . " has stopped");
8035
}
8036
}
8037
}
8038
}
8039
else {
8040
$logger->warning("$lib_dir/services does not exist");
8041
}
8042
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");
8050
}
8051
}
8052
8053
return;
8054
}
8055
8056
sub stop_agent {
8057
my (%args) = @_;
8058
8059
have_required_args(\%args, qw(
8060
pid_file
8061
lib_dir
8062
)) or die;
8063
my $pid_file = $args{pid_file};
8064
my $lib_dir = $args{lib_dir};
8065
8066
my $stopped = 0;
8067
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
8072
# the KILL signal.
8073
my $pid = eval {
8074
get_agent_pid(
8075
pid_file => $pid_file,
8076
);
8077
};
8078
if ( my $e = $EVAL_ERROR ) {
8079
if ( !blessed($e) ) {
8080
$logger->warning("Sorry, an error occured while getting the pt-agent PID: $e");
8081
}
8082
elsif ( $e->isa('Percona::Agent::Exception::PIDNotFound') ) {
8083
$logger->info("pt-agent is not running");
8084
$stopped = 1;
8085
}
8086
elsif ( $e->isa('Percona::Agent::Exception::PIDNotRunning') ) {
8087
$logger->warning("$e. pt-agent may have stopped unexpectedly or crashed.");
8088
$stopped = 1;
8089
}
8090
else { # unhandled exception
8091
$logger->warning("Sorry, an unknown exception occured while getting "
8092
. "the pt-agent PID: $e");
8093
}
8094
}
8095
else {
8096
$logger->info("Stopping pt-agent...");
8097
kill 15, $pid;
8098
my $running;
8099
for (1..5) {
8100
$running = kill 0, $pid;
8101
last if !$running;
8102
sleep 0.5;
8103
}
8104
$running = kill 0, $pid;
8105
if ( $running ) {
8106
$logger->warning("pt-agent did not respond to the TERM signal, using "
8107
. "the KILL signal...");
8108
kill 9, $pid;
8109
for (1..2) {
8110
$running = kill 0, $pid;
8111
last if !$running;
8112
sleep 0.5;
8113
}
8114
$running = kill 0, $pid;
8115
if ( $running ) {
8116
# Shouldn't happen:
8117
$logger->warning("pt-agent did not response to the KILL signal");
8118
}
8119
else {
8120
$logger->info("Killed pt-agent");
8121
$stopped = 1;
8122
}
8123
}
8124
else {
8125
$logger->info("pt-agent has stopped");
8126
$stopped = 1;
8127
}
8128
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 ) {
8132
unlink $pid_file
8133
or $logger->warning("Cannot remove $pid_file: $OS_ERROR. Remove "
8134
. "this file manually.");
8135
}
8136
}
8137
8138
stop_all_services(
8139
lib_dir => $lib_dir,
8140
);
8141
8142
# TODO: kill --lib/pids/*
8143
8144
return $stopped;
8145
}
8146
8147
sub stop_all_services {
8148
my (%args) = @_;
8149
8150
have_required_args(\%args, qw(
8151
lib_dir
8152
)) or die;
8153
my $lib_dir = $args{lib_dir};
8154
8155
# Optional args
8156
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir}
8157
: "$FindBin::Bin/";
8158
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...");
8162
eval {
8163
schedule_services(
8164
services => [],
8165
lib_dir => $lib_dir,
8166
quiet => 1,
8167
);
8168
};
8169
if ( $EVAL_ERROR ) {
8170
$logger->error("Error removing services from crontab: $EVAL_ERROR");
8171
}
8172
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();
8179
8180
SERVICE:
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"
8187
. " </dev/null"
8188
. " >$stop_log 2>&1";
8189
$logger->info("Stopping $service...");
8190
PTDEBUG && _d($cmd);
8191
system($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.");
8197
next SERVICE;
8198
}
8199
unlink $stop_log
8200
or $logger->warning("Cannot remove $stop_log: $OS_ERROR");
8201
}
8202
}
8203
else {
8204
$logger->info("$lib_dir/services does not exist, no services to stop")
8205
}
8206
8207
$state->{all_services_are_stopped} = 1;
8208
8209
return;
8210
}
8211
8212
sub stop_service {
8213
my (%args) = @_;
8214
8215
have_required_args(\%args, qw(
8216
service
8217
lib_dir
8218
)) or die;
8219
my $service = $args{service};
8220
my $lib_dir = $args{lib_dir};
8221
8222
# Optional args
8223
my $bin_dir = defined $args{bin_dir} ? $args{bin_dir}
8224
: "$FindBin::Bin/";
8225
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"
8235
. " </dev/null"
8236
. " >$stop_log 2>&1";
8237
$logger->info("Stopping $service...");
8238
PTDEBUG && _d($cmd);
8239
system($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.");
8246
}
8247
else {
8248
unlink $stop_log
8249
or $logger->warning("Cannot remove $stop_log: $OS_ERROR");
8250
}
8251
}
8252
else {
8253
$logger->warning("$stop_service_file does not exist, cannot stop $service");
8254
}
8255
}
8256
else {
8257
$logger->warning("$lib_dir/services does not exist, cannot stop $service");
8258
}
8259
8260
return;
8261
}
8262
8263
sub reset_agent {
8264
my (%args) = @_;
8265
8266
have_required_args(\%args, qw(
8267
pid_file
8268
lib_dir
8269
spool_dir
8270
log_file
8271
)) or die;
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};
8276
8277
# Optional args
8278
my $api_key = $args{api_key};
8279
8280
if ( -t STDIN ) {
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>;
8285
}
8286
8287
$logger->info('Stopping pt-agent...');
8288
my $stopped = stop_agent(
8289
pid_file => $pid_file,
8290
lib_dir => $lib_dir,
8291
);
8292
if ( !$stopped ) {
8293
$logger->warning('Failed to stop pt-agent. Stop the agent, or verify that '
8294
. 'it is no longer running, and try again.');
8295
return;
8296
}
8297
8298
my $agent = load_local_agent(
8299
lib_dir => $lib_dir,
8300
quiet => 1,
8301
);
8302
if ( !$agent ) {
8303
$logger->warning("$lib_dir/agent does not exist. You will need to re-install "
8304
. "pt-agent after the reset.");
8305
}
8306
8307
$logger->info("Removing $lib_dir/...");
8308
rmtree($lib_dir)
8309
or $logger->warning("Cannot remove $lib_dir/: $OS_ERROR");
8310
init_lib_dir(
8311
lib_dir => $lib_dir,
8312
);
8313
8314
if ( $agent ) {
8315
my $new_agent = Percona::WebAPI::Resource::Agent->new(
8316
uuid => $agent->uuid,
8317
);
8318
save_agent(
8319
lib_dir => $lib_dir,
8320
agent => $new_agent,
8321
);
8322
}
8323
8324
$logger->info("Removing $spool_dir/...");
8325
rmtree($spool_dir)
8326
or $logger->warning("Cannot remove $spool_dir/: $OS_ERROR");
8327
init_spool_dir(
8328
spool_dir => $spool_dir,
8329
);
8330
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");
8336
if ( $api_key ) {
8337
print { $fh } "api-key=$api_key\n";
8338
}
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";
8342
}
8343
close $fh
8344
or $logger->warning("Cannot close $config_file: $OS_ERROR");
8345
8346
if ( -f $log_file ) {
8347
$logger->info("Removing $log_file...");
8348
unlink $log_file
8349
or $logger->warning("Cannot remove $log_file: $OS_ERROR");
8350
}
8351
8352
return;
8353
}
8354
8355
sub get_agent_pid {
8356
my (%args) = @_;
8357
my $pid_file = $args{pid_file};
8358
8359
my $pid;
8360
if ( -f $pid_file ) {
8361
PTDEBUG && _d('Reading PID from', $pid_file);
8362
chop($pid = slurp($pid_file));
8363
}
8364
else {
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,
8370
);
8371
}
8372
# Match the first digits, which should be the PID.
8373
($pid) = $ps_output =~ m/(\d+)/;
8374
}
8375
8376
if ( !$pid ) {
8377
die Percona::Agent::Exception::NoPID->new(
8378
pid_file => $pid_file,
8379
pid_file_is_empty => -f $pid_file,
8380
);
8381
}
8382
8383
my $running = kill 0, $pid;
8384
if ( !$running ) {
8385
die Percona::Agent::Exception::PIDNotRunning->new(
8386
pid => $pid,
8387
);
8388
}
8389
8390
return $pid;
8391
}
8392
8393
sub reload_signal {
8394
my ( $signal ) = @_;
8395
print STDERR "\n# Caught SIG$signal, reloading configuration.\n";
8396
$state->{reload} = 1;
8397
return;
8398
}
8399
8400
sub reload_agent {
8401
my (%args) = @_;
8402
8403
have_required_args(\%args, qw(
8404
pid_file
8405
)) or die;
8406
my $pid_file = $args{pid_file};
8407
my $lib_dir = $args{lib_dir};
8408
8409
my $pid = eval {
8410
get_agent_pid(
8411
pid_file => $pid_file,
8412
);
8413
};
8414
if ( my $e = $EVAL_ERROR ) {
8415
if ( !blessed($e) ) {
8416
$logger->warning("Sorry, an error occured while getting the pt-agent PID: $e");
8417
}
8418
elsif ( $e->isa('Percona::Agent::Exception::PIDNotFound') ) {
8419
$logger->warning("pt-agent is not running");
8420
}
8421
elsif ( $e->isa('Percona::Agent::Exception::PIDNotRunning') ) {
8422
$logger->warning("$e. pt-agent may have stopped unexpectedly or crashed.");
8423
}
8424
else { # unhandled exception
8425
$logger->warning("Sorry, an unknown exception occured while getting "
8426
. "the pt-agent PID: $e");
8427
}
8428
}
8429
else {
8430
kill 10, $pid; # SIGUSR1, caught in reload_signal()
8431
$logger->info("Sent reload signal (SIGUSR1) to pt-agent PID $pid");
8432
}
8433
8434
return;
8435
}
8436
8437
# ############## #
8438
# --install subs #
8439
# ############## #
8440
8441
sub install {
8442
my (%args) = @_;
8443
have_required_args(\%args, qw(
8444
OptionParser
8445
Cxn
8446
flags
8447
)) or die;
8448
my $o = $args{OptionParser};
8449
my $cxn = $args{Cxn};
8450
my $flags = $args{flags};
8451
8452
# Optional args
8453
my $interactive = $args{interactive};
8454
8455
$logger->quiet(Percona::Agent::Logger::level_number('ERROR'));
8456
8457
my $agent_my_cnf = '/etc/percona/agent/my.cnf';
8458
my $config_file = get_config_file();
8459
my $lib_dir = $o->get('lib');
8460
8461
my $step_result;
8462
my $stepno = 0;
8463
my $skip = 0;
8464
my $step_fmt = "Step %d of %d: %s: ";
8465
my @steps = (
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",
8471
"Connect to MySQL",
8472
"Check if MySQL is a slave",
8473
"Create a MySQL user for the agent",
8474
"Initialize $agent_my_cnf",
8475
"Initialize $config_file",
8476
"Create the agent",
8477
"Run the agent",
8478
);
8479
my $n_steps = scalar @steps;
8480
my $next_step = sub {
8481
my (%args) = @_;
8482
my $repeat = $args{repeat};
8483
my $done = $args{done};
8484
# Result of the previous step
8485
my $result = 'OK';
8486
if ( $step_result ) {
8487
$result = $step_result;
8488
$step_result = undef;
8489
}
8490
print "$result\n" if $stepno && !$repeat;
8491
while ( $skip ) {
8492
printf $step_fmt,
8493
$stepno + ($repeat ? 0 : 1),
8494
$n_steps,
8495
$steps[$repeat ? $stepno - 1 : $stepno];
8496
$stepno++;
8497
print "SKIP\n";
8498
$skip--;
8499
}
8500
if ( $done ) {
8501
print "INSTALLATION COMPLETE\n";
8502
return;
8503
}
8504
# This step
8505
printf $step_fmt,
8506
$stepno + ($repeat ? 0 : 1),
8507
$n_steps,
8508
$steps[$repeat ? $stepno - 1 : $stepno];
8509
$stepno++ unless $repeat;
8510
};
8511
8512
# ########################################################################
8513
# Pre-install checklist
8514
# ########################################################################
8515
8516
# Must be root for --install.
8517
$next_step->();
8518
if ( $EUID != 0 ) {
8519
die "You must run pt-agent --install as root.\n";
8520
}
8521
8522
# Check Perl module dependencies
8523
$next_step->();
8524
exit 1 if missing_perl_module_deps();
8525
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"
8530
}
8531
8532
# Check for crontab
8533
$next_step->();
8534
my $crontab = `which crontab 2>/dev/null`;
8535
if ( !$crontab ) {
8536
die "cron is not installed, or crontab is not in your PATH.\n";
8537
}
8538
8539
# Verify pt-agent is not installed
8540
$next_step->();
8541
my @install_files = ($config_file, "$lib_dir/agent");
8542
my @have_files;
8543
foreach my $file (@install_files) {
8544
push @have_files, $file if -f $file;
8545
}
8546
if ( scalar @have_files ) {
8547
print "FAIL\n";
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";
8553
}
8554
8555
# Must have a valid API key.
8556
$next_step->();
8557
my $got_api_key = 0;
8558
my $api_key = $o->get('api-key');
8559
if ( !$api_key ) {
8560
print "\n";
8561
if ( $interactive || -t STDIN ) {
8562
while ( !$api_key ) {
8563
print "Enter your API key: ";
8564
$api_key = <STDIN>;
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";
8568
$api_key = '';
8569
}
8570
}
8571
}
8572
else {
8573
die "Please specify your --api-key.\n";
8574
}
8575
$got_api_key = 1;
8576
}
8577
8578
my $client;
8579
my $entry_links;
8580
if ( $flags->{offline} ) {
8581
$skip++;
8582
}
8583
else {
8584
if ($got_api_key) {
8585
$next_step->(repeat => 1);
8586
}
8587
eval {
8588
($client, $entry_links) = get_api_client(
8589
api_key => $api_key,
8590
interval => sub { return; },
8591
tries => 1,
8592
);
8593
};
8594
if ( my $e = $EVAL_ERROR ) {
8595
die "Sorry, an error occurred while verifying the API key: $e";
8596
}
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";
8600
}
8601
else {
8602
my $err = $client->response->message || 'Unknown error';
8603
die "Sorry, an error occured while verifying the API key: $err\n";
8604
}
8605
}
8606
}
8607
8608
# Must be able to connect to MySQL to create pt_agent user.
8609
$next_step->();
8610
eval {
8611
$cxn->connect();
8612
};
8613
if ( $EVAL_ERROR ) {
8614
chomp $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";
8619
}
8620
8621
# Check if MySQL is a slave
8622
$next_step->();
8623
my $slave = $cxn->dbh->selectrow_hashref("SHOW SLAVE STATUS");
8624
if ( $slave ) {
8625
$step_result = 'YES, TO MASTER ' . $slave->{master_host} || '?';
8626
}
8627
else {
8628
$step_result = 'NO';
8629
}
8630
8631
# ########################################################################
8632
# Do the install
8633
# ########################################################################
8634
8635
# Create a MySQL user for the agent
8636
$next_step->();
8637
if ( -f $agent_my_cnf ) {
8638
$step_result = "NO, USE EXISTING $agent_my_cnf";
8639
}
8640
else {
8641
if ( !$slave ) { # master
8642
create_mysql_user($cxn, $agent_my_cnf);
8643
}
8644
else { # slave
8645
if ( $flags->{force_dangerous_slave_install} ) {
8646
create_mysql_user($cxn, $agent_my_cnf);
8647
}
8648
else {
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";
8655
}
8656
}
8657
}
8658
8659
# Save the API key and defaults file in ~/.pt-agent.conf.
8660
$next_step->();
8661
eval {
8662
write_to_file(
8663
data => "api-key=$api_key\ndefaults-file=$agent_my_cnf\n",
8664
file => $config_file,
8665
);
8666
};
8667
if ( $EVAL_ERROR ) {
8668
die "Sorry, an error occured while initializing $config_file: "
8669
. $EVAL_ERROR;
8670
}
8671
8672
# Init --lib and --spool. pt-agent would do this itself, but we'll
8673
# do it now in case there are problems.
8674
$next_step->();
8675
init_lib_dir(
8676
lib_dir => $lib_dir,
8677
);
8678
init_spool_dir(
8679
spool_dir => $o->get('spool'),
8680
);
8681
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
8688
}
8689
else {
8690
$next_step->();
8691
my $running = eval {
8692
start_agent(
8693
api_key => $api_key,
8694
lib_dir => $o->get('lib'),
8695
Cxn => $cxn,
8696
client => $client,
8697
entry_links => $entry_links,
8698
agent_uuid => $o->get('agent-uuid'),
8699
daemonize => 0,
8700
pid_file => undef,
8701
log_file => undef,
8702
tries => 2,
8703
interval => sub { sleep 2; },
8704
);
8705
};
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";
8711
}
8712
else {
8713
die "Sorry, an error occurred while starting the agent: $EVAL_ERROR";
8714
}
8715
}
8716
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
8720
# have any yet).
8721
$next_step->();
8722
my $env = env_vars();
8723
my $cmd = "$env $FindBin::Bin/pt-agent --daemonize";
8724
my $ret = system($cmd);
8725
if ( $ret >> 8 ) {
8726
die "Sorry, an error occured while starting pt-agent.\n";
8727
}
8728
}
8729
8730
# ########################################################################
8731
# Done installing
8732
# ########################################################################
8733
$next_step->(done => 1);
8734
8735
my $hostname = `hostname`;
8736
chomp($hostname);
8737
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";
8743
}
8744
else {
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";
8749
}
8750
8751
return;
8752
}
8753
8754
sub create_mysql_user {
8755
my ($cxn, $agent_my_cnf, $user, $pass) = @_;
8756
8757
if ( !$user || !$pass ) {
8758
$user = 'pt_agent';
8759
$pass = pseudo_random_password();
8760
8761
my $sql = "GRANT SUPER,USAGE ON *.* TO 'pt_agent'\@'localhost' "
8762
. "IDENTIFIED BY '$pass'";
8763
eval {
8764
$cxn->dbh->do($sql);
8765
};
8766
if ( $EVAL_ERROR ) {
8767
die "Sorry, an error occurred while creating a MySQL user for the agent: "
8768
. $EVAL_ERROR;
8769
}
8770
$cxn->dbh->disconnect();
8771
}
8772
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.
8780
8781
if ( !-d '/etc/percona' ) {
8782
_safe_mkdir('/etc/percona');
8783
}
8784
if ( !-d '/etc/percona/agent' ) {
8785
_safe_mkdir('/etc/percona/agent');
8786
}
8787
my $my_cnf = "[client]\nuser=$user\npass=$pass\n";
8788
my $dsn = $cxn->dsn;
8789
if ( $dsn->{h} ) {
8790
$my_cnf .= "host=$dsn->{h}\n";
8791
}
8792
if ( $dsn->{P} ) {
8793
$my_cnf .= "port=$dsn->{P}\n";
8794
}
8795
if ( $dsn->{S} ) {
8796
$my_cnf .= "socket=$dsn->{S}\n";
8797
}
8798
eval {
8799
write_to_file(
8800
data => $my_cnf,
8801
file => $agent_my_cnf,
8802
);
8803
};
8804
if ( $EVAL_ERROR ) {
8805
die "Sorry, an error occured while initializing $agent_my_cnf: "
8806
. $EVAL_ERROR;
8807
}
8808
8809
return;
8810
}
8811
8812
sub pseudo_random_password {
8813
my @chars = ("A".."Z", "a".."z", "0".."9");
8814
my $string;
8815
$string .= $chars[rand @chars] for 1..9;
8816
return $string;
8817
}
8818
8819
sub missing_perl_module_deps {
8820
my @missing_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;
8826
}
8827
}
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";
8832
}
8833
}
8834
return scalar @missing_deps;
8835
}
8836
8837
# ################ #
8838
# --uninstall subs #
8839
# ################ #
8840
8841
sub uninstall {
8842
my (%args) = @_;
8843
have_required_args(\%args, qw(
8844
OptionParser
8845
Cxn
8846
)) or die;
8847
my $o = $args{OptionParser};
8848
my $cxn = $args{Cxn};
8849
my $flags = $args{flags};
8850
8851
if ( $EUID != 0 ) {
8852
die "You must run pt-agent --uninstall as root.\n";
8853
}
8854
8855
my $config_file = get_config_file();
8856
my $lib_dir = $o->get('lib');
8857
my $spool_dir = $o->get('spool');
8858
8859
print "Uninstalling pt-agent...\n";
8860
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'),
8866
);
8867
if ( !$stopped ) {
8868
$logger->fatal("Failed to stop pt-agent.");
8869
}
8870
8871
# Agent is stopped so now it's safe to remove all our files and dirs.
8872
my @shell_cmds;
8873
if ( -d $lib_dir ) {
8874
push @shell_cmds, "rm -rf $lib_dir";
8875
}
8876
if ( -d $spool_dir ) {
8877
push @shell_cmds, "rm -rf $spool_dir"
8878
}
8879
if ( -d "/etc/percona/agent" ) {
8880
push @shell_cmds, "rm -rf /etc/percona/agent/";
8881
}
8882
if ( -f $config_file ) {
8883
push @shell_cmds, "rm -f $config_file"
8884
}
8885
8886
my $rm_files_ok;
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' ) {
8896
last;
8897
}
8898
else {
8899
$rm_files_ok = 0;
8900
}
8901
}
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 ) {
8905
print "$cmd\n";
8906
system($cmd);
8907
if ( $CHILD_ERROR ) {
8908
warn "Command failed: $cmd\n";
8909
$rm_files_ok = 0;
8910
}
8911
}
8912
}
8913
else {
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";
8918
}
8919
8920
eval {
8921
$cxn->connect();
8922
};
8923
if ( $EVAL_ERROR ) {
8924
chomp $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";
8929
}
8930
8931
my $drop_mysql_user_ok;
8932
eval {
8933
$cxn->dbh->selectall_arrayref("SHOW GRANTS FOR 'pt_agent'\@'localhost'");
8934
};
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' ) {
8944
last;
8945
}
8946
else {
8947
$drop_mysql_user_ok = 0;
8948
}
8949
}
8950
# CTRL-C should prevent us from getting here, but just in case:
8951
return unless $drop_mysql_user_ok;
8952
eval {
8953
$cxn->dbh->do($sql);
8954
};
8955
if ( $EVAL_ERROR ) {
8956
warn "Error dropping the pt-agent MySQL user: $EVAL_ERROR";
8957
$drop_mysql_user_ok = 0;
8958
}
8959
}
8960
else {
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";
8965
}
8966
8967
print "\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";
8973
}
8974
else {
8975
warn "Uninstalling pt-agent failed. See previous output for errors "
8976
. "and try again. Contact Percona if you need help.\n";
8977
}
8978
8979
return
8980
}
8981
8982
# ################## #
8983
# Misc and util subs #
8984
# ################## #
8985
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;
8990
}
8991
8992
sub save_agent {
8993
my (%args) = @_;
8994
have_required_args(\%args, qw(
8995
agent
8996
lib_dir
8997
)) or die;
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");
9002
eval {
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";
9007
close $fh
9008
or die "Error closing $file: $OS_ERROR";
9009
};
9010
if ( $EVAL_ERROR ) {
9011
if ( !$state->{save_agent_error}++ ) {
9012
chomp($EVAL_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.");
9016
}
9017
}
9018
delete $state->{save_agent_error};
9019
return;
9020
}
9021
9022
sub slurp {
9023
my ($file) = @_;
9024
return unless -f $file;
9025
open my $fh, '<', $file
9026
or die "Error opening $file: $OS_ERROR";
9027
my $data = do {
9028
local $INPUT_RECORD_SEPARATOR = undef;
9029
<$fh>;
9030
};
9031
close $fh;
9032
return $data;
9033
}
9034
9035
sub write_to_file {
9036
my (%args) = @_;
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;
9043
close $fh;
9044
return;
9045
}
9046
9047
sub _set_logger {
9048
my $new_logger = shift;
9049
$logger = $new_logger;
9050
return;
9051
}
9052
9053
sub get_versions {
9054
my (%args) = @_;
9055
my $cxn = $args{Cxn};
9056
my $tries = $args{tries} || 1;
9057
my $interval = $args{interval} || sub { return; };
9058
9059
# This is currently the actual response from GET v.percona.com
9060
my $fake_response = <<EOL;
9061
OS;os_version
9062
MySQL;mysql_variable;version_comment,version
9063
Perl;perl_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
9070
EOL
9071
9072
my $items = VersionCheck::parse_server_response(
9073
response => $fake_response,
9074
);
9075
9076
my $instances = [
9077
{ name => 'system', id => 0, },
9078
];
9079
9080
my $have_mysql = -1;
9081
if ( !$cxn->dbh || !$cxn->dbh->ping() ) {
9082
$logger->debug("Connecting to MySQL");
9083
eval {
9084
$cxn->connect();
9085
};
9086
if ( $EVAL_ERROR ) {
9087
$logger->debug("Cannot connect to MySQL: $EVAL_ERROR");
9088
$have_mysql = 0;
9089
}
9090
else {
9091
$have_mysql = 1;
9092
}
9093
}
9094
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 },
9099
);
9100
push @$instances,
9101
{ name => $name, id => $id, dbh => $cxn->dbh, dsn => $cxn->dsn };
9102
9103
# Disconnect MySQL if we connected it.
9104
if ( $have_mysql == 1 ) {
9105
$logger->debug("Disconnecting MySQL");
9106
eval {
9107
$cxn->dbh->disconnect();
9108
};
9109
if ( $EVAL_ERROR ) {
9110
$logger->debug($EVAL_ERROR);
9111
}
9112
}
9113
}
9114
9115
my $versions = VersionCheck::get_versions(
9116
items => $items,
9117
instances => $instances,
9118
);
9119
9120
my %version_for;
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};
9127
}
9128
}
9129
else {
9130
$version_for{$item} = $versions->{$item};
9131
}
9132
}
9133
9134
PTDEBUG && _d('Versions:', Dumper(\%version_for));
9135
return \%version_for;
9136
}
9137
9138
sub env_vars {
9139
my @vars;
9140
foreach my $var ( qw(
9141
PTDEBUG
9142
PERCONA_TOOLKIT_TEST_USE_DSN_NAMES
9143
PCT_ENTRY_LINK
9144
)) {
9145
if ( my $val = $ENV{$var} ) {
9146
push @vars, "$var=\"$val\"";
9147
}
9148
}
9149
return join(' ', @vars);
9150
}
9151
9152
sub _safe_mkdir {
9153
my $dir = shift;
9154
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.
9160
eval {
9161
mkdir $dir or die $OS_ERROR;
9162
};
9163
if ( my $e = $EVAL_ERROR ) {
9164
if ( $e =~ /exists/i && -d $dir ) {
9165
PTDEBUG && _d('Another process created', $dir);
9166
}
9167
else {
9168
die "Cannot mkdir $dir: $e";
9169
}
9170
}
9171
return;
9172
}
9173
9174
sub check_if_mysql_restarted {
9175
my (%args) = @_;
9176
have_required_args(\%args, qw(
9177
dbh
9178
)) or die;
9179
my $dbh = $args{dbh};
9180
9181
# Optional args
9182
my $uptime = $args{uptime}; # for testing
9183
my $margin = $args{margin} || 5;
9184
9185
if ( !$uptime ) {
9186
my $sql = "SHOW STATUS LIKE 'uptime'";
9187
eval {
9188
(undef, $uptime) = $dbh->selectrow_array($sql);
9189
};
9190
if ( $EVAL_ERROR ) {
9191
$logger->error("$sql: $EVAL_ERROR");
9192
return;
9193
}
9194
}
9195
9196
my $now = int(time);
9197
9198
if ( !$state->{last_uptime} || !$state->{last_uptime_check} ) {
9199
$logger->debug("MySQL uptime: $uptime");
9200
delete $state->{mysql_restarted};
9201
}
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;
9214
}
9215
}
9216
9217
$state->{last_uptime} = $uptime;
9218
$state->{last_uptime_check} = $now;
9219
9220
return;
9221
}
9222
9223
sub too_many_agents {
9224
my (%args) = @_;
9225
have_required_args(\%args, qw(
9226
lib_dir
9227
)) or die;
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;
9232
}
9233
9234
sub ping_api {
9235
my (%args) = @_;
9236
have_required_args(\%args, qw(
9237
client
9238
)) or die;
9239
my $client = $args{client};
9240
my $ping_link = $client->entry_link . '/ping';
9241
$ping_link =~ s!//ping!/ping!g; # //ping doesn't work
9242
eval {
9243
$client->get(
9244
link => $ping_link,
9245
);
9246
};
9247
return $EVAL_ERROR ? 0 : 1;
9248
}
9249
9250
sub _logger {
9251
my $_logger = shift;
9252
$logger = $_logger if $_logger;
9253
return $logger;
9254
}
9255
9256
sub _state {
9257
my $_state = shift;
9258
$state = $_state if $_state;
9259
return $state;
9260
}
9261
9262
# Catches signals so we can exit gracefully.
9263
sub sig_int {
9264
my ( $signal ) = @_;
9265
$oktorun = 0;
9266
if ( $exit_on_signals ) {
9267
print STDERR "\n# Caught SIG$signal, exiting.\n";
9268
exit 1;
9269
}
9270
print STDERR "# Caught SIG$signal. Use 'kill -ABRT $PID' if "
9271
. "the tool does not exit normally in a few seconds.\n";
9272
return;
9273
}
9274
9275
# ############################################################################
9276
# Run the program.
9277
# ############################################################################
9278
9279
if ( !caller ) { exit main(@ARGV); }
9280
9281
1; # Because this is a module as well as a script.
9282
9283
# ############################################################################
9284
# Documentation
9285
# ############################################################################
9286
=pod
9287
9288
=head1 NAME
9289
9290
pt-agent - Agent for Percona Cloud Tools
9291
9292
=head1 SYNOPSIS
9293
9294
Usage: pt-agent [OPTIONS]
9295
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.
9300
9301
=head1 DESCRIPTION
9302
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.
9306
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">).
9309
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.
9316
9317
=head1 INSTALLING
9318
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.
9322
9323
Installing the agent as root is very simple:
9324
9325
# pt-agent --install
9326
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
9330
services for agent.
9331
9332
Please contact Percona if you need help installing the agent.
9333
9334
=head2 SLAVE INSTALL
9335
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.
9344
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.
9350
9351
=head2 Percona XtraDB Cluster (PXC) INSTALL
9352
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.
9361
9362
=head1 MYSQL USER
9363
9364
During L<"--install">, pt-agent creates the following MySQL user:
9365
9366
GRANT SUPER, USAGE ON *.* TO 'pt_agent'@'localhost' IDENTIFIED BY 'pass'
9367
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>.
9371
9372
=head1 EXIT STATUS
9373
9374
pt-agent exists zero if no errors or warnings occurred, else it exits non-zero.
9375
9376
=head1 OPTIONS
9377
9378
L<"--run-service"> and L<"--send-data"> are mutually exclusive.
9379
9380
L<"--status">, L<"--stop">, and L<"--reset"> are mutually exclusive.
9381
9382
=over
9383
9384
=item --[no]agent-api
9385
9386
default: yes
9387
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.
9390
9391
=item --agent-uuid
9392
9393
type: string
9394
9395
Existing agent UUID for re-installing an agent.
9396
9397
=item --api-key
9398
9399
type: string
9400
9401
Your secret Percona Cloud Tools API key.
9402
9403
=item --ask-pass
9404
9405
Prompt for MySQL password.
9406
9407
=item --check-interval
9408
9409
type: time; default: 1m
9410
9411
How often to check for a new configuration and services.
9412
9413
=item --config
9414
9415
type: Array
9416
9417
Read this comma-separated list of config files; if specified, this must be the
9418
first option on the command line.
9419
9420
See the L<"--help"> output for a list of default config files.
9421
9422
=item --daemonize
9423
9424
Daemonize the agent. This causes the agent to fork into the background and
9425
L<"--log"> all output.
9426
9427
Fork to the background and detach from the shell. POSIX operating systems only.
9428
9429
=item --defaults-file
9430
9431
short form: -F; type: string
9432
9433
Only read MySQL options from the given file. You must give an absolute
9434
pathname.
9435
9436
=item --disk-bytes-free
9437
9438
type: size; default: 100M
9439
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.
9442
9443
Valid size value suffixes are k, M, G, and T.
9444
9445
=item --disk-pct-free
9446
9447
type: int; default: 5
9448
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.
9451
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.
9456
9457
=item --help
9458
9459
Print the agent's help and exit.
9460
9461
=item --host
9462
9463
short form: -h; type: string; default: localhost
9464
9465
MySQL host.
9466
9467
=item --install
9468
9469
Install pt-agent as root.
9470
9471
=item --install-options
9472
9473
type: Hash
9474
9475
Comma-separated list of L<"--install"> options. Options are:
9476
9477
=over
9478
9479
=item offline
9480
9481
Do not verify the API key or start the agent.
9482
9483
=item force_dangerous_slave_install
9484
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.
9494
9495
=back
9496
9497
=item --interactive
9498
9499
Run in interactive mode (disables L<"--[no]log-api">).
9500
9501
=item --lib
9502
9503
type: string; default: /var/lib/pt-agent
9504
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
9507
manually.
9508
9509
=item --log
9510
9511
type: string; default: /var/log/pt-agent.log
9512
9513
Log all output to this file when daemonized.
9514
9515
=item --[no]log-api
9516
9517
default: yes
9518
9519
Log everything through the Percona Cloud Tools API.
9520
9521
=item --password
9522
9523
short form: -p; type: string
9524
9525
MySQL password.
9526
9527
=item --pid
9528
9529
type: string; default: /var/run/pt-agent.pid
9530
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.
9539
9540
=item --ping
9541
9542
Ping the Percona Cloud Tools API and exit.
9543
9544
=item --port
9545
9546
short form: -P; type: int
9547
9548
MySQL port number.
9549
9550
=item --reload
9551
9552
Force pt-agent to reload its configuration immediately.
9553
9554
=item --reset
9555
9556
cumulative: yes; default: 0
9557
9558
Reset pt-agent to a clean post-install state.
9559
9560
B<WARNING>: all L<"--spool"> data will be deleted.
9561
9562
=item --run-service
9563
9564
type: string
9565
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.
9569
9570
=item --send-data
9571
9572
type: string
9573
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
9576
this option.
9577
9578
=item --set-vars
9579
9580
type: Array
9581
9582
Set the MySQL variables in this comma-separated list of C<variable=value> pairs.
9583
9584
By default, the agent sets:
9585
9586
=for comment ignore-pt-internal-value
9587
MAGIC_set_vars
9588
9589
wait_timeout=10000
9590
9591
Variables specified on the command line override these defaults. For
9592
example, specifying C<--set-vars wait_timeout=500> overrides the default
9593
value of C<10000>.
9594
9595
The agent prints a warning and continues if a variable cannot be set.
9596
9597
=item --socket
9598
9599
short form: -S; type: string
9600
9601
MySQL socket file.
9602
9603
=item --spool
9604
9605
type: string; default: /var/spool/pt-agent
9606
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.
9612
9613
=item --status
9614
9615
Print the status of pt-agent.
9616
9617
=item --stop
9618
9619
Stop pt-agent and all services.
9620
9621
=item --uninstall
9622
9623
Completely remove pt-agent and all its data from the server. This does not
9624
delete the agent from https://cloud.percona.com.
9625
9626
=item --user
9627
9628
short form: -u; type: string
9629
9630
MySQL user, if not the current system user.
9631
9632
=item --version
9633
9634
Print the agent's version and exit.
9635
9636
=back
9637
9638
=head1 DSN OPTIONS
9639
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.
9645
9646
=over
9647
9648
=item * A
9649
9650
dsn: charset; copy: yes
9651
9652
Default character set.
9653
9654
=item * D
9655
9656
copy: no
9657
9658
Default database when connecting.
9659
9660
=item * F
9661
9662
dsn: mysql_read_default_file; copy: yes
9663
9664
Defaults file for connection values.
9665
9666
=item * h
9667
9668
dsn: host; copy: yes
9669
9670
MySQL host.
9671
9672
=item * p
9673
9674
dsn: password; copy: yes
9675
9676
MySQL password.
9677
9678
=item * P
9679
9680
dsn: port; copy: yes
9681
9682
MySQL port number.
9683
9684
=item * S
9685
9686
dsn: mysql_socket; copy: no
9687
9688
MySQL socket file.
9689
9690
=item * u
9691
9692
dsn: user; copy: yes
9693
9694
MySQL user, if not the current system user.
9695
9696
=back
9697
9698
=head1 ENVIRONMENT
9699
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:
9702
9703
PTDEBUG=1 pt-agent ... > FILE 2>&1
9704
9705
Be careful: debugging output is voluminous and can generate several megabytes
9706
of output.
9707
9708
=head1 SYSTEM REQUIREMENTS
9709
9710
pt-agent requires:
9711
9712
=over
9713
9714
=item * A Percona Cloud Tools account (https://cloud.percona.com)
9715
9716
=item * Access to https://cloud-api.percona.com
9717
9718
=item * Perl 5.8 or newer
9719
9720
=item * Standard Linux bin tools (grep, awk, stat, etc.)
9721
9722
=item * cron
9723
9724
=item * A Bash shell
9725
9726
=item * Core Perl modules
9727
9728
=item * DBD::mysql Perl module
9729
9730
=item * JSON Perl module
9731
9732
=item * LWP (>= v5.813) Perl module
9733
9734
=item * IO::Socket::SSL Perl module
9735
9736
=back
9737
9738
=head1 BUGS
9739
9740
For a list of known bugs, see L<http://www.percona.com/bugs/pt-agent>.
9741
9742
Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
9743
Include the following information in your bug report:
9744
9745
=over
9746
9747
=item * Complete command-line used to run the tool
9748
9749
=item * Tool L<"--version">
9750
9751
=item * MySQL version of all servers involved
9752
9753
=item * Output from the tool including STDERR
9754
9755
=item * Input files (log/dump/config files, etc.)
9756
9757
=back
9758
9759
If possible, include debugging output by running the tool with C<PTDEBUG>;
9760
see L<"ENVIRONMENT">.
9761
9762
=head1 DOWNLOADING
9763
9764
Visit L<http://www.percona.com/software/percona-toolkit/> to download the
9765
latest release of Percona Toolkit.
9766
9767
=head1 AUTHORS
9768
9769
Daniel Nichter
9770
9771
=head1 ABOUT PERCONA TOOLKIT
9772
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.
9779
9780
=head1 COPYRIGHT, LICENSE, AND WARRANTY
9781
9782
This program is copyright 2013-2014 Percona LLC and/or its affiliates.
9783
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.
9787
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
9792
licenses.
9793
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.
9797
9798
=head1 VERSION
9799
9800
pt-agent 2.2.7
9801
9802
=cut
Loggerhead is a web-based interface for Breezy
Version: 2.0.1