Merge lp:~percona-toolkit-dev/percona-toolkit/remove-pt-agent into lp:~percona-toolkit-dev/percona-toolkit/release-2.2.8

Proposed by Daniel Nichter on 2014-04-26
Status: Merged
Approved by: Daniel Nichter on 2014-04-26
Approved revision: 599
Merged at revision: 600
Proposed branch: lp:~percona-toolkit-dev/percona-toolkit/remove-pt-agent
Merge into: lp:~percona-toolkit-dev/percona-toolkit/release-2.2.8
Diff against target: 14753 lines (+2/-14551)
37 files modified
Changelog (+2/-0)
bin/pt-agent (+0/-9802)
lib/Percona/Agent/Logger.pm (+0/-341)
lib/Percona/Test/Mock/AgentLogger.pm (+0/-129)
lib/Percona/Test/Mock/UserAgent.pm (+0/-71)
lib/Percona/WebAPI/Client.pm (+0/-321)
lib/Percona/WebAPI/Exception/Request.pm (+0/-69)
lib/Percona/WebAPI/Exception/Resource.pm (+0/-66)
lib/Percona/WebAPI/Representation.pm (+0/-86)
lib/Percona/WebAPI/Resource/Agent.pm (+0/-77)
lib/Percona/WebAPI/Resource/Config.pm (+0/-55)
lib/Percona/WebAPI/Resource/LogEntry.pm (+0/-66)
lib/Percona/WebAPI/Resource/Service.pm (+0/-94)
lib/Percona/WebAPI/Resource/Task.pm (+0/-62)
t/lib/Percona/WebAPI/Client.t (+0/-236)
t/lib/Percona/WebAPI/Representation.t (+0/-51)
t/pt-agent/basics.t (+0/-101)
t/pt-agent/get_services.t (+0/-423)
t/pt-agent/init_agent.t (+0/-333)
t/pt-agent/make_new_crontab.t (+0/-151)
t/pt-agent/replace_special_vars.t (+0/-73)
t/pt-agent/run_agent.t (+0/-527)
t/pt-agent/run_service.t (+0/-503)
t/pt-agent/samples/crontab001.out (+0/-2)
t/pt-agent/samples/crontab002.in (+0/-1)
t/pt-agent/samples/crontab002.out (+0/-3)
t/pt-agent/samples/crontab003.in (+0/-3)
t/pt-agent/samples/crontab003.out (+0/-3)
t/pt-agent/samples/crontab004.in (+0/-2)
t/pt-agent/samples/crontab004.out (+0/-2)
t/pt-agent/samples/query-history/data001.json (+0/-152)
t/pt-agent/samples/query-history/data001.send (+0/-166)
t/pt-agent/samples/service001 (+0/-19)
t/pt-agent/samples/write_services001 (+0/-19)
t/pt-agent/schedule_services.t (+0/-200)
t/pt-agent/send_data.t (+0/-234)
t/pt-agent/write_services.t (+0/-108)
To merge this branch: bzr merge lp:~percona-toolkit-dev/percona-toolkit/remove-pt-agent
Reviewer Review Type Date Requested Status
Daniel Nichter Approve on 2014-04-26
Review via email: mp+217325@code.launchpad.net
To post a comment you must log in.
review: Approve
600. By Daniel Nichter on 2014-04-26

Remove pt-agent.

Preview Diff

[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
1=== modified file 'Changelog'
2--- Changelog 2014-02-20 08:10:16 +0000
3+++ Changelog 2014-04-26 04:29:24 +0000
4@@ -1,5 +1,7 @@
5 Changelog for Percona Toolkit
6
7+ * Removed pt-agent
8+
9 v2.2.7 released 2014-02-20
10
11 * Fixed bug 1279502: --version-check behaves like spyware
12
13=== removed file 'bin/pt-agent'
14--- bin/pt-agent 2014-02-20 08:10:16 +0000
15+++ bin/pt-agent 1970-01-01 00:00:00 +0000
16@@ -1,9802 +0,0 @@
17-#!/usr/bin/env perl
18-
19-# This program is part of Percona Toolkit: http://www.percona.com/software/
20-# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
21-# notices and disclaimers.
22-
23-use strict;
24-use warnings FATAL => 'all';
25-
26-# This tool is "fat-packed": most of its dependent modules are embedded
27-# in this file. Setting %INC to this file for each module makes Perl aware
28-# of this so it will not try to load the module from @INC. See the tool's
29-# documentation for a full list of dependencies.
30-BEGIN {
31- $INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
32- Percona::Toolkit
33- Lmo::Utils
34- Lmo::Meta
35- Lmo::Object
36- Lmo::Types
37- Lmo
38- Percona::WebAPI::Representation
39- Percona::WebAPI::Client
40- Percona::WebAPI::Exception::Request
41- Percona::WebAPI::Exception::Resource
42- Percona::WebAPI::Resource::Agent
43- Percona::WebAPI::Resource::Config
44- Percona::WebAPI::Resource::Service
45- Percona::WebAPI::Resource::Task
46- Percona::WebAPI::Resource::LogEntry
47- VersionCheck
48- DSNParser
49- OptionParser
50- Cxn
51- Quoter
52- VersionParser
53- Daemon
54- Transformers
55- Safeguards
56- Percona::Agent::Logger
57- ));
58-}
59-
60-# ###########################################################################
61-# Percona::Toolkit package
62-# This package is a copy without comments from the original. The original
63-# with comments and its test file can be found in the Bazaar repository at,
64-# lib/Percona/Toolkit.pm
65-# t/lib/Percona/Toolkit.t
66-# See https://launchpad.net/percona-toolkit for more information.
67-# ###########################################################################
68-{
69-package Percona::Toolkit;
70-
71-our $VERSION = '2.2.7';
72-
73-use strict;
74-use warnings FATAL => 'all';
75-use English qw(-no_match_vars);
76-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
77-
78-use Carp qw(carp cluck);
79-use Data::Dumper qw();
80-
81-require Exporter;
82-our @ISA = qw(Exporter);
83-our @EXPORT_OK = qw(
84- have_required_args
85- Dumper
86- _d
87-);
88-
89-sub have_required_args {
90- my ($args, @required_args) = @_;
91- my $have_required_args = 1;
92- foreach my $arg ( @required_args ) {
93- if ( !defined $args->{$arg} ) {
94- $have_required_args = 0;
95- carp "Argument $arg is not defined";
96- }
97- }
98- cluck unless $have_required_args; # print backtrace
99- return $have_required_args;
100-}
101-
102-sub Dumper {
103- local $Data::Dumper::Indent = 1;
104- local $Data::Dumper::Sortkeys = 1;
105- local $Data::Dumper::Quotekeys = 0;
106- Data::Dumper::Dumper(@_);
107-}
108-
109-sub _d {
110- my ($package, undef, $line) = caller 0;
111- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
112- map { defined $_ ? $_ : 'undef' }
113- @_;
114- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
115-}
116-
117-1;
118-}
119-# ###########################################################################
120-# End Percona::Toolkit package
121-# ###########################################################################
122-
123-# ###########################################################################
124-# Lmo::Utils package
125-# This package is a copy without comments from the original. The original
126-# with comments and its test file can be found in the Bazaar repository at,
127-# lib/Lmo/Utils.pm
128-# t/lib/Lmo/Utils.t
129-# See https://launchpad.net/percona-toolkit for more information.
130-# ###########################################################################
131-{
132-package Lmo::Utils;
133-
134-use strict;
135-use warnings qw( FATAL all );
136-require Exporter;
137-our (@ISA, @EXPORT, @EXPORT_OK);
138-
139-BEGIN {
140- @ISA = qw(Exporter);
141- @EXPORT = @EXPORT_OK = qw(
142- _install_coderef
143- _unimport_coderefs
144- _glob_for
145- _stash_for
146- );
147-}
148-
149-{
150- no strict 'refs';
151- sub _glob_for {
152- return \*{shift()}
153- }
154-
155- sub _stash_for {
156- return \%{ shift() . "::" };
157- }
158-}
159-
160-sub _install_coderef {
161- my ($to, $code) = @_;
162-
163- return *{ _glob_for $to } = $code;
164-}
165-
166-sub _unimport_coderefs {
167- my ($target, @names) = @_;
168- return unless @names;
169- my $stash = _stash_for($target);
170- foreach my $name (@names) {
171- if ($stash->{$name} and defined(&{$stash->{$name}})) {
172- delete $stash->{$name};
173- }
174- }
175-}
176-
177-1;
178-}
179-# ###########################################################################
180-# End Lmo::Utils package
181-# ###########################################################################
182-
183-# ###########################################################################
184-# Lmo::Meta package
185-# This package is a copy without comments from the original. The original
186-# with comments and its test file can be found in the Bazaar repository at,
187-# lib/Lmo/Meta.pm
188-# t/lib/Lmo/Meta.t
189-# See https://launchpad.net/percona-toolkit for more information.
190-# ###########################################################################
191-{
192-package Lmo::Meta;
193-use strict;
194-use warnings qw( FATAL all );
195-
196-my %metadata_for;
197-
198-sub new {
199- my $class = shift;
200- return bless { @_ }, $class
201-}
202-
203-sub metadata_for {
204- my $self = shift;
205- my ($class) = @_;
206-
207- return $metadata_for{$class} ||= {};
208-}
209-
210-sub class { shift->{class} }
211-
212-sub attributes {
213- my $self = shift;
214- return keys %{$self->metadata_for($self->class)}
215-}
216-
217-sub attributes_for_new {
218- my $self = shift;
219- my @attributes;
220-
221- my $class_metadata = $self->metadata_for($self->class);
222- while ( my ($attr, $meta) = each %$class_metadata ) {
223- if ( exists $meta->{init_arg} ) {
224- push @attributes, $meta->{init_arg}
225- if defined $meta->{init_arg};
226- }
227- else {
228- push @attributes, $attr;
229- }
230- }
231- return @attributes;
232-}
233-
234-1;
235-}
236-# ###########################################################################
237-# End Lmo::Meta package
238-# ###########################################################################
239-
240-# ###########################################################################
241-# Lmo::Object package
242-# This package is a copy without comments from the original. The original
243-# with comments and its test file can be found in the Bazaar repository at,
244-# lib/Lmo/Object.pm
245-# t/lib/Lmo/Object.t
246-# See https://launchpad.net/percona-toolkit for more information.
247-# ###########################################################################
248-{
249-package Lmo::Object;
250-
251-use strict;
252-use warnings qw( FATAL all );
253-
254-use Carp ();
255-use Scalar::Util qw(blessed);
256-
257-use Lmo::Meta;
258-use Lmo::Utils qw(_glob_for);
259-
260-sub new {
261- my $class = shift;
262- my $args = $class->BUILDARGS(@_);
263-
264- my $class_metadata = Lmo::Meta->metadata_for($class);
265-
266- my @args_to_delete;
267- while ( my ($attr, $meta) = each %$class_metadata ) {
268- next unless exists $meta->{init_arg};
269- my $init_arg = $meta->{init_arg};
270-
271- if ( defined $init_arg ) {
272- $args->{$attr} = delete $args->{$init_arg};
273- }
274- else {
275- push @args_to_delete, $attr;
276- }
277- }
278-
279- delete $args->{$_} for @args_to_delete;
280-
281- for my $attribute ( keys %$args ) {
282- if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
283- $args->{$attribute} = $coerce->($args->{$attribute});
284- }
285- if ( my $isa_check = $class_metadata->{$attribute}{isa} ) {
286- my ($check_name, $check_sub) = @$isa_check;
287- $check_sub->($args->{$attribute});
288- }
289- }
290-
291- while ( my ($attribute, $meta) = each %$class_metadata ) {
292- next unless $meta->{required};
293- Carp::confess("Attribute ($attribute) is required for $class")
294- if ! exists $args->{$attribute}
295- }
296-
297- my $self = bless $args, $class;
298-
299- my @build_subs;
300- my $linearized_isa = mro::get_linear_isa($class);
301-
302- for my $isa_class ( @$linearized_isa ) {
303- unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE};
304- }
305- my @args = %$args;
306- for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
307- $sub->( $self, @args);
308- }
309- return $self;
310-}
311-
312-sub BUILDARGS {
313- shift; # No need for the classname
314- if ( @_ == 1 && ref($_[0]) ) {
315- Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]")
316- unless ref($_[0]) eq ref({});
317- return {%{$_[0]}} # We want a new reference, always
318- }
319- else {
320- return { @_ };
321- }
322-}
323-
324-sub meta {
325- my $class = shift;
326- $class = Scalar::Util::blessed($class) || $class;
327- return Lmo::Meta->new(class => $class);
328-}
329-
330-1;
331-}
332-# ###########################################################################
333-# End Lmo::Object package
334-# ###########################################################################
335-
336-# ###########################################################################
337-# Lmo::Types package
338-# This package is a copy without comments from the original. The original
339-# with comments and its test file can be found in the Bazaar repository at,
340-# lib/Lmo/Types.pm
341-# t/lib/Lmo/Types.t
342-# See https://launchpad.net/percona-toolkit for more information.
343-# ###########################################################################
344-{
345-package Lmo::Types;
346-
347-use strict;
348-use warnings qw( FATAL all );
349-
350-use Carp ();
351-use Scalar::Util qw(looks_like_number blessed);
352-
353-
354-our %TYPES = (
355- Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) },
356- Num => sub { defined $_[0] && looks_like_number($_[0]) },
357- Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) },
358- Str => sub { defined $_[0] },
359- Object => sub { defined $_[0] && blessed($_[0]) },
360- FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened },
361-
362- map {
363- my $type = /R/ ? $_ : uc $_;
364- $_ . "Ref" => sub { ref $_[0] eq $type }
365- } qw(Array Code Hash Regexp Glob Scalar)
366-);
367-
368-sub check_type_constaints {
369- my ($attribute, $type_check, $check_name, $val) = @_;
370- ( ref($type_check) eq 'CODE'
371- ? $type_check->($val)
372- : (ref $val eq $type_check
373- || ($val && $val eq $type_check)
374- || (exists $TYPES{$type_check} && $TYPES{$type_check}->($val)))
375- )
376- || Carp::confess(
377- qq<Attribute ($attribute) does not pass the type constraint because: >
378- . qq<Validation failed for '$check_name' with value >
379- . (defined $val ? Lmo::Dumper($val) : 'undef') )
380-}
381-
382-sub _nested_constraints {
383- my ($attribute, $aggregate_type, $type) = @_;
384-
385- my $inner_types;
386- if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
387- $inner_types = _nested_constraints($1, $2);
388- }
389- else {
390- $inner_types = $TYPES{$type};
391- }
392-
393- if ( $aggregate_type eq 'ArrayRef' ) {
394- return sub {
395- my ($val) = @_;
396- return unless ref($val) eq ref([]);
397-
398- if ($inner_types) {
399- for my $value ( @{$val} ) {
400- return unless $inner_types->($value)
401- }
402- }
403- else {
404- for my $value ( @{$val} ) {
405- return unless $value && ($value eq $type
406- || (Scalar::Util::blessed($value) && $value->isa($type)));
407- }
408- }
409- return 1;
410- };
411- }
412- elsif ( $aggregate_type eq 'Maybe' ) {
413- return sub {
414- my ($value) = @_;
415- return 1 if ! defined($value);
416- if ($inner_types) {
417- return unless $inner_types->($value)
418- }
419- else {
420- return unless $value eq $type
421- || (Scalar::Util::blessed($value) && $value->isa($type));
422- }
423- return 1;
424- }
425- }
426- else {
427- Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
428- }
429-}
430-
431-1;
432-}
433-# ###########################################################################
434-# End Lmo::Types package
435-# ###########################################################################
436-
437-# ###########################################################################
438-# Lmo package
439-# This package is a copy without comments from the original. The original
440-# with comments and its test file can be found in the Bazaar repository at,
441-# lib/Lmo.pm
442-# t/lib/Lmo.t
443-# See https://launchpad.net/percona-toolkit for more information.
444-# ###########################################################################
445-{
446-BEGIN {
447-$INC{"Lmo.pm"} = __FILE__;
448-package Lmo;
449-our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
450-
451-
452-use strict;
453-use warnings qw( FATAL all );
454-
455-use Carp ();
456-use Scalar::Util qw(looks_like_number blessed);
457-
458-use Lmo::Meta;
459-use Lmo::Object;
460-use Lmo::Types;
461-
462-use Lmo::Utils;
463-
464-my %export_for;
465-sub import {
466- warnings->import(qw(FATAL all));
467- strict->import();
468-
469- my $caller = scalar caller(); # Caller's package
470- my %exports = (
471- extends => \&extends,
472- has => \&has,
473- with => \&with,
474- override => \&override,
475- confess => \&Carp::confess,
476- );
477-
478- $export_for{$caller} = \%exports;
479-
480- for my $keyword ( keys %exports ) {
481- _install_coderef "${caller}::$keyword" => $exports{$keyword};
482- }
483-
484- if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
485- @_ = "Lmo::Object";
486- goto *{ _glob_for "${caller}::extends" }{CODE};
487- }
488-}
489-
490-sub extends {
491- my $caller = scalar caller();
492- for my $class ( @_ ) {
493- _load_module($class);
494- }
495- _set_package_isa($caller, @_);
496- _set_inherited_metadata($caller);
497-}
498-
499-sub _load_module {
500- my ($class) = @_;
501-
502- (my $file = $class) =~ s{::|'}{/}g;
503- $file .= '.pm';
504- { local $@; eval { require "$file" } } # or warn $@;
505- return;
506-}
507-
508-sub with {
509- my $package = scalar caller();
510- require Role::Tiny;
511- for my $role ( @_ ) {
512- _load_module($role);
513- _role_attribute_metadata($package, $role);
514- }
515- Role::Tiny->apply_roles_to_package($package, @_);
516-}
517-
518-sub _role_attribute_metadata {
519- my ($package, $role) = @_;
520-
521- my $package_meta = Lmo::Meta->metadata_for($package);
522- my $role_meta = Lmo::Meta->metadata_for($role);
523-
524- %$package_meta = (%$role_meta, %$package_meta);
525-}
526-
527-sub has {
528- my $names = shift;
529- my $caller = scalar caller();
530-
531- my $class_metadata = Lmo::Meta->metadata_for($caller);
532-
533- for my $attribute ( ref $names ? @$names : $names ) {
534- my %args = @_;
535- my $method = ($args{is} || '') eq 'ro'
536- ? sub {
537- Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
538- if $#_;
539- return $_[0]{$attribute};
540- }
541- : sub {
542- return $#_
543- ? $_[0]{$attribute} = $_[1]
544- : $_[0]{$attribute};
545- };
546-
547- $class_metadata->{$attribute} = ();
548-
549- if ( my $type_check = $args{isa} ) {
550- my $check_name = $type_check;
551-
552- if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
553- $type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
554- }
555-
556- my $check_sub = sub {
557- my ($new_val) = @_;
558- Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
559- };
560-
561- $class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
562- my $orig_method = $method;
563- $method = sub {
564- $check_sub->($_[1]) if $#_;
565- goto &$orig_method;
566- };
567- }
568-
569- if ( my $builder = $args{builder} ) {
570- my $original_method = $method;
571- $method = sub {
572- $#_
573- ? goto &$original_method
574- : ! exists $_[0]{$attribute}
575- ? $_[0]{$attribute} = $_[0]->$builder
576- : goto &$original_method
577- };
578- }
579-
580- if ( my $code = $args{default} ) {
581- Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
582- unless ref($code) eq 'CODE';
583- my $original_method = $method;
584- $method = sub {
585- $#_
586- ? goto &$original_method
587- : ! exists $_[0]{$attribute}
588- ? $_[0]{$attribute} = $_[0]->$code
589- : goto &$original_method
590- };
591- }
592-
593- if ( my $role = $args{does} ) {
594- my $original_method = $method;
595- $method = sub {
596- if ( $#_ ) {
597- Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
598- unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
599- }
600- goto &$original_method
601- };
602- }
603-
604- if ( my $coercion = $args{coerce} ) {
605- $class_metadata->{$attribute}{coerce} = $coercion;
606- my $original_method = $method;
607- $method = sub {
608- if ( $#_ ) {
609- return $original_method->($_[0], $coercion->($_[1]))
610- }
611- goto &$original_method;
612- }
613- }
614-
615- _install_coderef "${caller}::$attribute" => $method;
616-
617- if ( $args{required} ) {
618- $class_metadata->{$attribute}{required} = 1;
619- }
620-
621- if ($args{clearer}) {
622- _install_coderef "${caller}::$args{clearer}"
623- => sub { delete shift->{$attribute} }
624- }
625-
626- if ($args{predicate}) {
627- _install_coderef "${caller}::$args{predicate}"
628- => sub { exists shift->{$attribute} }
629- }
630-
631- if ($args{handles}) {
632- _has_handles($caller, $attribute, \%args);
633- }
634-
635- if (exists $args{init_arg}) {
636- $class_metadata->{$attribute}{init_arg} = $args{init_arg};
637- }
638- }
639-}
640-
641-sub _has_handles {
642- my ($caller, $attribute, $args) = @_;
643- my $handles = $args->{handles};
644-
645- my $ref = ref $handles;
646- my $kv;
647- if ( $ref eq ref [] ) {
648- $kv = { map { $_,$_ } @{$handles} };
649- }
650- elsif ( $ref eq ref {} ) {
651- $kv = $handles;
652- }
653- elsif ( $ref eq ref qr// ) {
654- Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
655- unless $args->{isa};
656- my $target_class = $args->{isa};
657- $kv = {
658- map { $_, $_ }
659- grep { $_ =~ $handles }
660- grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
661- grep { !$export_for{$target_class}->{$_} }
662- keys %{ _stash_for $target_class }
663- };
664- }
665- else {
666- Carp::confess("handles for $ref not yet implemented");
667- }
668-
669- while ( my ($method, $target) = each %{$kv} ) {
670- my $name = _glob_for "${caller}::$method";
671- Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
672- if defined &$name;
673-
674- my ($target, @curried_args) = ref($target) ? @$target : $target;
675- *$name = sub {
676- my $self = shift;
677- my $delegate_to = $self->$attribute();
678- my $error = "Cannot delegate $method to $target because the value of $attribute";
679- Carp::confess("$error is not defined") unless $delegate_to;
680- Carp::confess("$error is not an object (got '$delegate_to')")
681- unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
682- return $delegate_to->$target(@curried_args, @_);
683- }
684- }
685-}
686-
687-sub _set_package_isa {
688- my ($package, @new_isa) = @_;
689- my $package_isa = \*{ _glob_for "${package}::ISA" };
690- @{*$package_isa} = @new_isa;
691-}
692-
693-sub _set_inherited_metadata {
694- my $class = shift;
695- my $class_metadata = Lmo::Meta->metadata_for($class);
696- my $linearized_isa = mro::get_linear_isa($class);
697- my %new_metadata;
698-
699- for my $isa_class (reverse @$linearized_isa) {
700- my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
701- %new_metadata = (
702- %new_metadata,
703- %$isa_metadata,
704- );
705- }
706- %$class_metadata = %new_metadata;
707-}
708-
709-sub unimport {
710- my $caller = scalar caller();
711- my $target = caller;
712- _unimport_coderefs($target, keys %{$export_for{$caller}});
713-}
714-
715-sub Dumper {
716- require Data::Dumper;
717- local $Data::Dumper::Indent = 0;
718- local $Data::Dumper::Sortkeys = 0;
719- local $Data::Dumper::Quotekeys = 0;
720- local $Data::Dumper::Terse = 1;
721-
722- Data::Dumper::Dumper(@_)
723-}
724-
725-BEGIN {
726- if ($] >= 5.010) {
727- { local $@; require mro; }
728- }
729- else {
730- local $@;
731- eval {
732- require MRO::Compat;
733- } or do {
734- *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
735- no strict 'refs';
736-
737- my $classname = shift;
738-
739- my @lin = ($classname);
740- my %stored;
741- foreach my $parent (@{"$classname\::ISA"}) {
742- my $plin = mro::get_linear_isa_dfs($parent);
743- foreach (@$plin) {
744- next if exists $stored{$_};
745- push(@lin, $_);
746- $stored{$_} = 1;
747- }
748- }
749- return \@lin;
750- };
751- }
752- }
753-}
754-
755-sub override {
756- my ($methods, $code) = @_;
757- my $caller = scalar caller;
758-
759- for my $method ( ref($methods) ? @$methods : $methods ) {
760- my $full_method = "${caller}::${method}";
761- *{_glob_for $full_method} = $code;
762- }
763-}
764-
765-}
766-1;
767-}
768-# ###########################################################################
769-# End Lmo package
770-# ###########################################################################
771-
772-# ###########################################################################
773-# Percona::WebAPI::Representation package
774-# This package is a copy without comments from the original. The original
775-# with comments and its test file can be found in the Bazaar repository at,
776-# lib/Percona/WebAPI/Representation.pm
777-# t/lib/Percona/WebAPI/Representation.t
778-# See https://launchpad.net/percona-toolkit for more information.
779-# ###########################################################################
780-{
781-package Percona::WebAPI::Representation;
782-
783-eval {
784- require JSON;
785-};
786-
787-require Exporter;
788-our @ISA = qw(Exporter);
789-our @EXPORT_OK = qw(
790- as_hashref
791- as_json
792- as_config
793-);
794-
795-sub as_hashref {
796- my ($resource, %args) = @_;
797-
798- my $as_hashref = { %$resource };
799-
800- if ( !defined $args{with_links} || !$args{with_links} ) {
801- delete $as_hashref->{links};
802- }
803-
804- return $as_hashref;
805-}
806-
807-sub as_json {
808- my ($resource, %args) = @_;
809-
810- my $json = $args{json} || JSON->new;
811- $json->allow_blessed([]);
812- $json->convert_blessed([]);
813-
814- my $text = $json->encode(
815- ref $resource eq 'ARRAY' ? $resource : as_hashref($resource, %args)
816- );
817- if ( $args{json} && $text ) { # for testing
818- chomp($text);
819- $text .= "\n";
820- }
821- return $text;
822-}
823-
824-sub as_config {
825- my $resource = shift;
826- if ( !$resource->isa('Percona::WebAPI::Resource::Config') ) {
827- die "Only Config resources can be represented as config.\n";
828- }
829- my $as_hashref = as_hashref($resource);
830- my $options = $as_hashref->{options};
831- my $config = join("\n",
832- map { defined $options->{$_} ? "$_=$options->{$_}" : "$_" }
833- sort keys %$options
834- ) . "\n";
835- return $config;
836-}
837-
838-1;
839-}
840-# ###########################################################################
841-# End Percona::WebAPI::Representation package
842-# ###########################################################################
843-
844-# ###########################################################################
845-# Percona::WebAPI::Client package
846-# This package is a copy without comments from the original. The original
847-# with comments and its test file can be found in the Bazaar repository at,
848-# lib/Percona/WebAPI/Client.pm
849-# t/lib/Percona/WebAPI/Client.t
850-# See https://launchpad.net/percona-toolkit for more information.
851-# ###########################################################################
852-{
853-package Percona::WebAPI::Client;
854-
855-our $VERSION = '0.01';
856-
857-use strict;
858-use warnings FATAL => 'all';
859-use English qw(-no_match_vars);
860-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
861-
862-eval {
863- require LWP;
864- require JSON;
865-};
866-
867-use Scalar::Util qw(blessed);
868-
869-use Lmo;
870-use Percona::Toolkit;
871-use Percona::WebAPI::Representation;
872-use Percona::WebAPI::Exception::Request;
873-use Percona::WebAPI::Exception::Resource;
874-
875-Percona::WebAPI::Representation->import(qw(as_json));
876-Percona::Toolkit->import(qw(_d Dumper have_required_args));
877-
878-has 'api_key' => (
879- is => 'ro',
880- isa => 'Str',
881- required => 1,
882-);
883-
884-has 'entry_link' => (
885- is => 'rw',
886- isa => 'Str',
887- required => 0,
888- default => sub { return 'https://cloud-api.percona.com' },
889-);
890-
891-has 'ua' => (
892- is => 'rw',
893- isa => 'Object',
894- lazy => 1,
895- required => 0,
896- builder => '_build_ua',
897-);
898-
899-has 'response' => (
900- is => 'rw',
901- isa => 'Object',
902- required => 0,
903- default => undef,
904-);
905-
906-sub _build_ua {
907- my $self = shift;
908- my $ua = LWP::UserAgent->new;
909- $ua->agent("Percona::WebAPI::Client/$Percona::WebAPI::Client::VERSION");
910- $ua->default_header('Content-Type', 'application/json');
911- $ua->default_header('X-Percona-API-Key', $self->api_key);
912- return $ua;
913-}
914-
915-sub get {
916- my ($self, %args) = @_;
917-
918- have_required_args(\%args, qw(
919- link
920- )) or die;
921- my ($link) = $args{link};
922-
923- eval {
924- $self->_request(
925- method => 'GET',
926- link => $link,
927- );
928- };
929- if ( my $e = $EVAL_ERROR ) {
930- if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
931- die $e;
932- }
933- else {
934- die "Unknown error: $e";
935- }
936- }
937-
938- my $resource = eval {
939- JSON::decode_json($self->response->content);
940- };
941- if ( $EVAL_ERROR ) {
942- warn sprintf "Error decoding resource: %s: %s",
943- $self->response->content,
944- $EVAL_ERROR;
945- return;
946- }
947-
948- my $resource_objects;
949- if ( my $type = $self->response->headers->{'x-percona-resource-type'} ) {
950- eval {
951- $type = "Percona::WebAPI::Resource::$type";
952- if ( ref $resource eq 'ARRAY' ) {
953- PTDEBUG && _d('Got a list of', $type, 'resources');
954- $resource_objects = [];
955- foreach my $attribs ( @$resource ) {
956- my $obj = $type->new(%$attribs);
957- push @$resource_objects, $obj;
958- }
959- }
960- else {
961- PTDEBUG && _d('Got a', $type, 'resource', Dumper($resource));
962- $resource_objects = $type->new(%$resource);
963- }
964- };
965- if ( my $e = $EVAL_ERROR ) {
966- die Percona::WebAPI::Exception::Resource->new(
967- type => $type,
968- link => $link,
969- data => (ref $resource eq 'ARRAY' ? $resource : [ $resource ]),
970- error => $e,
971- );
972- }
973- }
974- elsif ( exists $resource->{links} ) {
975- $resource_objects = $resource->{links};
976- }
977- elsif ( exists $resource->{pong} ) {
978- PTDEBUG && _d("Ping pong!");
979- }
980- else {
981- warn "Did not get X-Percona-Resource-Type or links from $link\n";
982- }
983-
984- return $resource_objects;
985-}
986-
987-sub post {
988- my $self = shift;
989- $self->_set(
990- @_,
991- method => 'POST',
992- );
993- return $self->response->header('Location');
994-}
995-
996-sub put {
997- my $self = shift;
998- $self->_set(
999- @_,
1000- method => 'PUT',
1001- );
1002- return $self->response->header('Location');
1003-}
1004-
1005-sub delete {
1006- my ($self, %args) = @_;
1007- have_required_args(\%args, qw(
1008- link
1009- )) or die;
1010- my ($link) = $args{link};
1011-
1012- eval {
1013- $self->_request(
1014- method => 'DELETE',
1015- link => $link,
1016- headers => { 'Content-Length' => 0 },
1017- );
1018- };
1019- if ( my $e = $EVAL_ERROR ) {
1020- if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
1021- die $e;
1022- }
1023- else {
1024- die "Unknown error: $e";
1025- }
1026- }
1027-
1028- return;
1029-}
1030-
1031-sub _set {
1032- my ($self, %args) = @_;
1033- have_required_args(\%args, qw(
1034- method
1035- resources
1036- link
1037- )) or die;
1038- my $method = $args{method};
1039- my $res = $args{resources};
1040- my $link = $args{link};
1041-
1042- my $headers = $args{headers};
1043-
1044- my $content = '';
1045- if ( ref($res) eq 'ARRAY' ) {
1046- PTDEBUG && _d('List of resources');
1047- $content = '[' . join(",\n", map { as_json($_) } @$res) . ']';
1048- }
1049- elsif ( ref($res) ) {
1050- PTDEBUG && _d('Resource object');
1051- $content = as_json($res);
1052- }
1053- elsif ( $res !~ m/\n/ && -f $res ) {
1054- PTDEBUG && _d('List of resources in file', $res);
1055- $content = '[';
1056- my $data = do {
1057- local $INPUT_RECORD_SEPARATOR = undef;
1058- open my $fh, '<', $res
1059- or die "Error opening $res: $OS_ERROR";
1060- <$fh>;
1061- };
1062- $data =~ s/,?\s*$/]/;
1063- $content .= $data;
1064- }
1065- else {
1066- PTDEBUG && _d('Resource text');
1067- $content = $res;
1068- }
1069-
1070- eval {
1071- $self->_request(
1072- method => $method,
1073- link => $link,
1074- content => $content,
1075- headers => $headers,
1076- );
1077- };
1078- if ( my $e = $EVAL_ERROR ) {
1079- if (blessed($e) && $e->isa('Percona::WebAPI::Exception::Request')) {
1080- die $e;
1081- }
1082- else {
1083- die "Unknown error: $e";
1084- }
1085- }
1086-
1087- return;
1088-}
1089-
1090-sub _request {
1091- my ($self, %args) = @_;
1092-
1093- have_required_args(\%args, qw(
1094- method
1095- link
1096- )) or die;
1097- my $method = $args{method};
1098- my $link = $args{link};
1099-
1100- my $content = $args{content};
1101- my $headers = $args{headers};
1102-
1103- my $req = HTTP::Request->new($method => $link);
1104- if ( $content ) {
1105- $req->content($content);
1106- }
1107- if ( $headers ) {
1108- map { $req->header($_ => $headers->{$_}) } keys %$headers;
1109- }
1110- PTDEBUG && _d('Request', $method, $link, Dumper($req));
1111-
1112- my $response = $self->ua->request($req);
1113- PTDEBUG && _d('Response', Dumper($response));
1114-
1115- $self->response($response);
1116-
1117- if ( !($response->code >= 200 && $response->code < 400) ) {
1118- die Percona::WebAPI::Exception::Request->new(
1119- method => $method,
1120- url => $link,
1121- content => $content,
1122- status => $response->code,
1123- error => "Failed to $method $link",
1124- );
1125- }
1126-
1127- return;
1128-}
1129-
1130-no Lmo;
1131-1;
1132-}
1133-# ###########################################################################
1134-# End Percona::WebAPI::Client package
1135-# ###########################################################################
1136-
1137-# ###########################################################################
1138-# Percona::WebAPI::Exception::Request package
1139-# This package is a copy without comments from the original. The original
1140-# with comments and its test file can be found in the Bazaar repository at,
1141-# lib/Percona/WebAPI/Exception/Request.pm
1142-# t/lib/Percona/WebAPI/Exception/Request.t
1143-# See https://launchpad.net/percona-toolkit for more information.
1144-# ###########################################################################
1145-{
1146-package Percona::WebAPI::Exception::Request;
1147-
1148-use Lmo;
1149-use overload '""' => \&as_string;
1150-
1151-has 'method' => (
1152- is => 'ro',
1153- isa => 'Str',
1154- required => 1,
1155-);
1156-
1157-has 'url' => (
1158- is => 'ro',
1159- isa => 'Str',
1160- required => 1,
1161-);
1162-
1163-has 'content' => (
1164- is => 'ro',
1165- isa => 'Maybe[Str]',
1166- required => 0,
1167-);
1168-
1169-has 'status' => (
1170- is => 'ro',
1171- isa => 'Int',
1172- required => 1,
1173-);
1174-
1175-has 'error' => (
1176- is => 'ro',
1177- isa => 'Str',
1178- required => 1,
1179-);
1180-
1181-sub as_string {
1182- my $self = shift;
1183- chomp(my $error = $self->error);
1184- $error =~ s/\n/ /g;
1185- return sprintf "%s\nRequest: %s %s %s\nStatus: %d\n",
1186- $error, $self->method, $self->url, $self->content || '', $self->status;
1187-}
1188-
1189-no Lmo;
1190-1;
1191-}
1192-# ###########################################################################
1193-# End Percona::WebAPI::Exception::Request package
1194-# ###########################################################################
1195-
1196-# ###########################################################################
1197-# Percona::WebAPI::Exception::Resource package
1198-# This package is a copy without comments from the original. The original
1199-# with comments and its test file can be found in the Bazaar repository at,
1200-# lib/Percona/WebAPI/Exception/Resource.pm
1201-# t/lib/Percona/WebAPI/Exception/Resource.t
1202-# See https://launchpad.net/percona-toolkit for more information.
1203-# ###########################################################################
1204-{
1205-package Percona::WebAPI::Exception::Resource;
1206-
1207-use Lmo;
1208-use overload '""' => \&as_string;
1209-use Data::Dumper;
1210-
1211-has 'type' => (
1212- is => 'ro',
1213- isa => 'Str',
1214- required => 1,
1215-);
1216-
1217-has 'link' => (
1218- is => 'ro',
1219- isa => 'Str',
1220- required => 1,
1221-);
1222-
1223-has 'data' => (
1224- is => 'ro',
1225- isa => 'ArrayRef',
1226- required => 1,
1227-);
1228-
1229-has 'error' => (
1230- is => 'ro',
1231- isa => 'Str',
1232- required => 1,
1233-);
1234-
1235-sub as_string {
1236- my $self = shift;
1237- chomp(my $error = $self->error);
1238- local $Data::Dumper::Indent = 1;
1239- local $Data::Dumper::Sortkeys = 1;
1240- local $Data::Dumper::Quotekeys = 0;
1241- return sprintf "Invalid %s resource from %s:\n\n%s\nError: %s\n\n",
1242- $self->type, $self->link, Dumper($self->data), $error;
1243-}
1244-
1245-no Lmo;
1246-1;
1247-}
1248-# ###########################################################################
1249-# End Percona::WebAPI::Exception::Resource package
1250-# ###########################################################################
1251-
1252-# ###########################################################################
1253-# Percona::WebAPI::Resource::Agent package
1254-# This package is a copy without comments from the original. The original
1255-# with comments and its test file can be found in the Bazaar repository at,
1256-# lib/Percona/WebAPI/Resource/Agent.pm
1257-# t/lib/Percona/WebAPI/Resource/Agent.t
1258-# See https://launchpad.net/percona-toolkit for more information.
1259-# ###########################################################################
1260-{
1261-package Percona::WebAPI::Resource::Agent;
1262-
1263-use Lmo;
1264-
1265-has 'uuid' => (
1266- is => 'ro',
1267- isa => 'Str',
1268- required => 0,
1269-);
1270-
1271-has 'username' => (
1272- is => 'rw',
1273- isa => 'Str',
1274- required => 0,
1275- default => sub { return $ENV{USER} || $ENV{LOGNAME} },
1276-);
1277-
1278-has 'hostname' => (
1279- is => 'rw',
1280- isa => 'Str',
1281- required => 0,
1282- default => sub {
1283- chomp(my $hostname = `hostname`);
1284- return $hostname;
1285- },
1286-);
1287-
1288-has 'alias' => (
1289- is => 'rw',
1290- isa => 'Str',
1291- required => 0,
1292-);
1293-
1294-has 'versions' => (
1295- is => 'rw',
1296- isa => 'Maybe[HashRef]',
1297- required => 0,
1298-);
1299-
1300-has 'links' => (
1301- is => 'rw',
1302- isa => 'Maybe[HashRef]',
1303- required => 0,
1304- default => sub { return {} },
1305-);
1306-
1307-sub name {
1308- my ($self) = @_;
1309- return $self->alias || $self->hostname || $self->uuid || 'Unknown';
1310-}
1311-
1312-no Lmo;
1313-1;
1314-}
1315-# ###########################################################################
1316-# End Percona::WebAPI::Resource::Agent package
1317-# ###########################################################################
1318-
1319-# ###########################################################################
1320-# Percona::WebAPI::Resource::Config package
1321-# This package is a copy without comments from the original. The original
1322-# with comments and its test file can be found in the Bazaar repository at,
1323-# lib/Percona/WebAPI/Resource/Config.pm
1324-# t/lib/Percona/WebAPI/Resource/Config.t
1325-# See https://launchpad.net/percona-toolkit for more information.
1326-# ###########################################################################
1327-{
1328-package Percona::WebAPI::Resource::Config;
1329-
1330-use Lmo;
1331-
1332-has 'ts' => (
1333- is => 'ro',
1334- isa => 'Int',
1335- required => 1,
1336-);
1337-
1338-has 'name' => (
1339- is => 'ro',
1340- isa => 'Str',
1341- required => 1,
1342-);
1343-
1344-has 'options' => (
1345- is => 'ro',
1346- isa => 'HashRef',
1347- required => 1,
1348-);
1349-
1350-has 'links' => (
1351- is => 'rw',
1352- isa => 'Maybe[HashRef]',
1353- required => 0,
1354- default => sub { return {} },
1355-);
1356-
1357-no Lmo;
1358-1;
1359-}
1360-# ###########################################################################
1361-# End Percona::WebAPI::Resource::Config package
1362-# ###########################################################################
1363-
1364-# ###########################################################################
1365-# Percona::WebAPI::Resource::Service package
1366-# This package is a copy without comments from the original. The original
1367-# with comments and its test file can be found in the Bazaar repository at,
1368-# lib/Percona/WebAPI/Resource/Service.pm
1369-# t/lib/Percona/WebAPI/Resource/Service.t
1370-# See https://launchpad.net/percona-toolkit for more information.
1371-# ###########################################################################
1372-{
1373-package Percona::WebAPI::Resource::Service;
1374-
1375-use Lmo;
1376-
1377-has 'ts' => (
1378- is => 'ro',
1379- isa => 'Int',
1380- required => 1,
1381-);
1382-
1383-has 'name' => (
1384- is => 'ro',
1385- isa => 'Str',
1386- required => 1,
1387-);
1388-
1389-has 'tasks' => (
1390- is => 'ro',
1391- isa => 'ArrayRef[Percona::WebAPI::Resource::Task]',
1392- required => 1,
1393-);
1394-
1395-has 'run_schedule' => (
1396- is => 'ro',
1397- isa => 'Str',
1398- required => 0,
1399-);
1400-
1401-has 'spool_schedule' => (
1402- is => 'ro',
1403- isa => 'Str',
1404- required => 0,
1405-);
1406-
1407-has 'meta' => (
1408- is => 'ro',
1409- isa => 'Bool',
1410- required => 0,
1411- default => sub { return 0 },
1412-);
1413-
1414-has 'run_once' => (
1415- is => 'ro',
1416- isa => 'Bool',
1417- required => 0,
1418- default => sub { return 0 },
1419-);
1420-
1421-has 'links' => (
1422- is => 'rw',
1423- isa => 'Maybe[HashRef]',
1424- required => 0,
1425- default => sub { return {} },
1426-);
1427-
1428-sub BUILDARGS {
1429- my ($class, %args) = @_;
1430- if ( ref $args{tasks} eq 'ARRAY' ) {
1431- my @tasks;
1432- foreach my $run_hashref ( @{$args{tasks}} ) {
1433- my $task = Percona::WebAPI::Resource::Task->new(%$run_hashref);
1434- push @tasks, $task;
1435- }
1436- $args{tasks} = \@tasks;
1437- }
1438- return $class->SUPER::BUILDARGS(%args);
1439-}
1440-
1441-no Lmo;
1442-1;
1443-}
1444-# ###########################################################################
1445-# End Percona::WebAPI::Resource::Service package
1446-# ###########################################################################
1447-
1448-# ###########################################################################
1449-# Percona::WebAPI::Resource::Task package
1450-# This package is a copy without comments from the original. The original
1451-# with comments and its test file can be found in the Bazaar repository at,
1452-# lib/Percona/WebAPI/Resource/Task.pm
1453-# t/lib/Percona/WebAPI/Resource/Task.t
1454-# See https://launchpad.net/percona-toolkit for more information.
1455-# ###########################################################################
1456-{
1457-package Percona::WebAPI::Resource::Task;
1458-
1459-use Lmo;
1460-
1461-has 'name' => (
1462- is => 'ro',
1463- isa => 'Str',
1464- required => 1,
1465-);
1466-
1467-has 'number' => (
1468- is => 'ro',
1469- isa => 'Int',
1470- required => 1,
1471-);
1472-
1473-has 'program' => (
1474- is => 'ro',
1475- isa => 'Maybe[Str]',
1476- required => 0,
1477-);
1478-
1479-has 'query' => (
1480- is => 'ro',
1481- isa => 'Maybe[Str]',
1482- required => 0,
1483-);
1484-
1485-has 'output' => (
1486- is => 'ro',
1487- isa => 'Maybe[Str]',
1488- required => 0,
1489-);
1490-
1491-sub TO_JSON { return { %{ shift() } }; }
1492-
1493-no Lmo;
1494-1;
1495-}
1496-# ###########################################################################
1497-# End Percona::WebAPI::Resource::Task package
1498-# ###########################################################################
1499-
1500-# ###########################################################################
1501-# Percona::WebAPI::Resource::LogEntry package
1502-# This package is a copy without comments from the original. The original
1503-# with comments and its test file can be found in the Bazaar repository at,
1504-# lib/Percona/WebAPI/Resource/LogEntry.pm
1505-# t/lib/Percona/WebAPI/Resource/LogEntry.t
1506-# See https://launchpad.net/percona-toolkit for more information.
1507-# ###########################################################################
1508-{
1509-package Percona::WebAPI::Resource::LogEntry;
1510-
1511-use Lmo;
1512-
1513-has 'pid' => (
1514- is => 'ro',
1515- isa => 'Int',
1516- required => 1,
1517-);
1518-
1519-has 'service' => (
1520- is => 'ro',
1521- isa => 'Str',
1522- required => 0,
1523-);
1524-
1525-has 'data_ts' => (
1526- is => 'ro',
1527- isa => 'Int',
1528- required => 0,
1529-);
1530-
1531-has 'entry_ts' => (
1532- is => 'ro',
1533- isa => 'Str',
1534- required => 1,
1535-);
1536-
1537-has 'log_level' => (
1538- is => 'ro',
1539- isa => 'Int',
1540- required => 1,
1541-);
1542-
1543-has 'message' => (
1544- is => 'ro',
1545- isa => 'Str',
1546- required => 1,
1547-);
1548-
1549-no Lmo;
1550-1;
1551-}
1552-# ###########################################################################
1553-# End Percona::WebAPI::Resource::LogEntry package
1554-# ###########################################################################
1555-
1556-# ###########################################################################
1557-# VersionCheck package
1558-# This package is a copy without comments from the original. The original
1559-# with comments and its test file can be found in the Bazaar repository at,
1560-# lib/VersionCheck.pm
1561-# t/lib/VersionCheck.t
1562-# See https://launchpad.net/percona-toolkit for more information.
1563-# ###########################################################################
1564-{
1565-package VersionCheck;
1566-
1567-
1568-use strict;
1569-use warnings FATAL => 'all';
1570-use English qw(-no_match_vars);
1571-
1572-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
1573-
1574-use Data::Dumper;
1575-local $Data::Dumper::Indent = 1;
1576-local $Data::Dumper::Sortkeys = 1;
1577-local $Data::Dumper::Quotekeys = 0;
1578-
1579-use Digest::MD5 qw(md5_hex);
1580-use Sys::Hostname qw(hostname);
1581-use File::Basename qw();
1582-use File::Spec;
1583-use FindBin qw();
1584-
1585-eval {
1586- require Percona::Toolkit;
1587- require HTTP::Micro;
1588-};
1589-
1590-{
1591- my $file = 'percona-version-check';
1592- my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
1593- my @vc_dirs = (
1594- '/etc/percona',
1595- '/etc/percona-toolkit',
1596- '/tmp',
1597- "$home",
1598- );
1599-
1600- sub version_check_file {
1601- foreach my $dir ( @vc_dirs ) {
1602- if ( -d $dir && -w $dir ) {
1603- PTDEBUG && _d('Version check file', $file, 'in', $dir);
1604- return $dir . '/' . $file;
1605- }
1606- }
1607- PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
1608- return $file; # in the CWD
1609- }
1610-}
1611-
1612-sub version_check_time_limit {
1613- return 60 * 60 * 24; # one day
1614-}
1615-
1616-
1617-sub version_check {
1618- my (%args) = @_;
1619-
1620- my $instances = $args{instances} || [];
1621- my $instances_to_check;
1622-
1623- PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
1624- if ( !$args{force} ) {
1625- if ( $FindBin::Bin
1626- && (-d "$FindBin::Bin/../.bzr" || -d "$FindBin::Bin/../../.bzr") ) {
1627- PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
1628- return;
1629- }
1630- }
1631-
1632- eval {
1633- foreach my $instance ( @$instances ) {
1634- my ($name, $id) = get_instance_id($instance);
1635- $instance->{name} = $name;
1636- $instance->{id} = $id;
1637- }
1638-
1639- push @$instances, { name => 'system', id => 0 };
1640-
1641- $instances_to_check = get_instances_to_check(
1642- instances => $instances,
1643- vc_file => $args{vc_file}, # testing
1644- now => $args{now}, # testing
1645- );
1646- PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
1647- return unless @$instances_to_check;
1648-
1649- my $protocol = 'https'; # optimistic, but...
1650- eval { require IO::Socket::SSL; };
1651- if ( $EVAL_ERROR ) {
1652- PTDEBUG && _d($EVAL_ERROR);
1653- $protocol = 'http';
1654- }
1655- PTDEBUG && _d('Using', $protocol);
1656-
1657- my $advice = pingback(
1658- instances => $instances_to_check,
1659- protocol => $protocol,
1660- url => $args{url} # testing
1661- || $ENV{PERCONA_VERSION_CHECK_URL} # testing
1662- || "$protocol://v.percona.com",
1663- );
1664- if ( $advice ) {
1665- PTDEBUG && _d('Advice:', Dumper($advice));
1666- if ( scalar @$advice > 1) {
1667- print "\n# " . scalar @$advice . " software updates are "
1668- . "available:\n";
1669- }
1670- else {
1671- print "\n# A software update is available:\n";
1672- }
1673- print join("\n", map { "# * $_" } @$advice), "\n\n";
1674- }
1675- };
1676- if ( $EVAL_ERROR ) {
1677- PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
1678- }
1679-
1680- if ( @$instances_to_check ) {
1681- eval {
1682- update_check_times(
1683- instances => $instances_to_check,
1684- vc_file => $args{vc_file}, # testing
1685- now => $args{now}, # testing
1686- );
1687- };
1688- if ( $EVAL_ERROR ) {
1689- PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
1690- }
1691- }
1692-
1693- if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
1694- warn "Exiting because the PTDEBUG_VERSION_CHECK "
1695- . "environment variable is defined.\n";
1696- exit 255;
1697- }
1698-
1699- return;
1700-}
1701-
1702-sub get_instances_to_check {
1703- my (%args) = @_;
1704-
1705- my $instances = $args{instances};
1706- my $now = $args{now} || int(time);
1707- my $vc_file = $args{vc_file} || version_check_file();
1708-
1709- if ( !-f $vc_file ) {
1710- PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
1711- 'version checking all instances');
1712- return $instances;
1713- }
1714-
1715- open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
1716- chomp(my $file_contents = do { local $/ = undef; <$fh> });
1717- PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
1718- close $fh;
1719- my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
1720-
1721- my $check_time_limit = version_check_time_limit();
1722- my @instances_to_check;
1723- foreach my $instance ( @$instances ) {
1724- my $last_check_time = $last_check_time_for{ $instance->{id} };
1725- PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
1726- $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
1727- 'hours until next check',
1728- sprintf '%.2f',
1729- ($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
1730- if ( !defined $last_check_time
1731- || ($now - $last_check_time) >= $check_time_limit ) {
1732- PTDEBUG && _d('Time to check', Dumper($instance));
1733- push @instances_to_check, $instance;
1734- }
1735- }
1736-
1737- return \@instances_to_check;
1738-}
1739-
1740-sub update_check_times {
1741- my (%args) = @_;
1742-
1743- my $instances = $args{instances};
1744- my $now = $args{now} || int(time);
1745- my $vc_file = $args{vc_file} || version_check_file();
1746- PTDEBUG && _d('Updating last check time:', $now);
1747-
1748- my %all_instances = map {
1749- $_->{id} => { name => $_->{name}, ts => $now }
1750- } @$instances;
1751-
1752- if ( -f $vc_file ) {
1753- open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
1754- my $contents = do { local $/ = undef; <$fh> };
1755- close $fh;
1756-
1757- foreach my $line ( split("\n", ($contents || '')) ) {
1758- my ($id, $ts) = split(',', $line);
1759- if ( !exists $all_instances{$id} ) {
1760- $all_instances{$id} = { ts => $ts }; # original ts, not updated
1761- }
1762- }
1763- }
1764-
1765- open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
1766- foreach my $id ( sort keys %all_instances ) {
1767- PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
1768- print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
1769- }
1770- close $fh;
1771-
1772- return;
1773-}
1774-
1775-sub get_instance_id {
1776- my ($instance) = @_;
1777-
1778- my $dbh = $instance->{dbh};
1779- my $dsn = $instance->{dsn};
1780-
1781- my $sql = q{SELECT CONCAT(@@hostname, @@port)};
1782- PTDEBUG && _d($sql);
1783- my ($name) = eval { $dbh->selectrow_array($sql) };
1784- if ( $EVAL_ERROR ) {
1785- PTDEBUG && _d($EVAL_ERROR);
1786- $sql = q{SELECT @@hostname};
1787- PTDEBUG && _d($sql);
1788- ($name) = eval { $dbh->selectrow_array($sql) };
1789- if ( $EVAL_ERROR ) {
1790- PTDEBUG && _d($EVAL_ERROR);
1791- $name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
1792- }
1793- else {
1794- $sql = q{SHOW VARIABLES LIKE 'port'};
1795- PTDEBUG && _d($sql);
1796- my (undef, $port) = eval { $dbh->selectrow_array($sql) };
1797- PTDEBUG && _d('port:', $port);
1798- $name .= $port || '';
1799- }
1800- }
1801- my $id = md5_hex($name);
1802-
1803- PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
1804-
1805- return $name, $id;
1806-}
1807-
1808-
1809-sub pingback {
1810- my (%args) = @_;
1811- my @required_args = qw(url instances);
1812- foreach my $arg ( @required_args ) {
1813- die "I need a $arg arugment" unless $args{$arg};
1814- }
1815- my $url = $args{url};
1816- my $instances = $args{instances};
1817-
1818- my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
1819-
1820- my $response = $ua->request('GET', $url);
1821- PTDEBUG && _d('Server response:', Dumper($response));
1822- die "No response from GET $url"
1823- if !$response;
1824- die("GET on $url returned HTTP status $response->{status}; expected 200\n",
1825- ($response->{content} || '')) if $response->{status} != 200;
1826- die("GET on $url did not return any programs to check")
1827- if !$response->{content};
1828-
1829- my $items = parse_server_response(
1830- response => $response->{content}
1831- );
1832- die "Failed to parse server requested programs: $response->{content}"
1833- if !scalar keys %$items;
1834-
1835- my $versions = get_versions(
1836- items => $items,
1837- instances => $instances,
1838- );
1839- die "Failed to get any program versions; should have at least gotten Perl"
1840- if !scalar keys %$versions;
1841-
1842- my $client_content = encode_client_response(
1843- items => $items,
1844- versions => $versions,
1845- general_id => md5_hex( hostname() ),
1846- );
1847-
1848- my $client_response = {
1849- headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
1850- content => $client_content,
1851- };
1852- PTDEBUG && _d('Client response:', Dumper($client_response));
1853-
1854- $response = $ua->request('POST', $url, $client_response);
1855- PTDEBUG && _d('Server suggestions:', Dumper($response));
1856- die "No response from POST $url $client_response"
1857- if !$response;
1858- die "POST $url returned HTTP status $response->{status}; expected 200"
1859- if $response->{status} != 200;
1860-
1861- return unless $response->{content};
1862-
1863- $items = parse_server_response(
1864- response => $response->{content},
1865- split_vars => 0,
1866- );
1867- die "Failed to parse server suggestions: $response->{content}"
1868- if !scalar keys %$items;
1869- my @suggestions = map { $_->{vars} }
1870- sort { $a->{item} cmp $b->{item} }
1871- values %$items;
1872-
1873- return \@suggestions;
1874-}
1875-
1876-sub encode_client_response {
1877- my (%args) = @_;
1878- my @required_args = qw(items versions general_id);
1879- foreach my $arg ( @required_args ) {
1880- die "I need a $arg arugment" unless $args{$arg};
1881- }
1882- my ($items, $versions, $general_id) = @args{@required_args};
1883-
1884- my @lines;
1885- foreach my $item ( sort keys %$items ) {
1886- next unless exists $versions->{$item};
1887- if ( ref($versions->{$item}) eq 'HASH' ) {
1888- my $mysql_versions = $versions->{$item};
1889- for my $id ( sort keys %$mysql_versions ) {
1890- push @lines, join(';', $id, $item, $mysql_versions->{$id});
1891- }
1892- }
1893- else {
1894- push @lines, join(';', $general_id, $item, $versions->{$item});
1895- }
1896- }
1897-
1898- my $client_response = join("\n", @lines) . "\n";
1899- return $client_response;
1900-}
1901-
1902-sub parse_server_response {
1903- my (%args) = @_;
1904- my @required_args = qw(response);
1905- foreach my $arg ( @required_args ) {
1906- die "I need a $arg arugment" unless $args{$arg};
1907- }
1908- my ($response) = @args{@required_args};
1909-
1910- my %items = map {
1911- my ($item, $type, $vars) = split(";", $_);
1912- if ( !defined $args{split_vars} || $args{split_vars} ) {
1913- $vars = [ split(",", ($vars || '')) ];
1914- }
1915- $item => {
1916- item => $item,
1917- type => $type,
1918- vars => $vars,
1919- };
1920- } split("\n", $response);
1921-
1922- PTDEBUG && _d('Items:', Dumper(\%items));
1923-
1924- return \%items;
1925-}
1926-
1927-my %sub_for_type = (
1928- os_version => \&get_os_version,
1929- perl_version => \&get_perl_version,
1930- perl_module_version => \&get_perl_module_version,
1931- mysql_variable => \&get_mysql_variable,
1932-);
1933-
1934-sub valid_item {
1935- my ($item) = @_;
1936- return unless $item;
1937- if ( !exists $sub_for_type{ $item->{type} } ) {
1938- PTDEBUG && _d('Invalid type:', $item->{type});
1939- return 0;
1940- }
1941- return 1;
1942-}
1943-
1944-sub get_versions {
1945- my (%args) = @_;
1946- my @required_args = qw(items);
1947- foreach my $arg ( @required_args ) {
1948- die "I need a $arg arugment" unless $args{$arg};
1949- }
1950- my ($items) = @args{@required_args};
1951-
1952- my %versions;
1953- foreach my $item ( values %$items ) {
1954- next unless valid_item($item);
1955- eval {
1956- my $version = $sub_for_type{ $item->{type} }->(
1957- item => $item,
1958- instances => $args{instances},
1959- );
1960- if ( $version ) {
1961- chomp $version unless ref($version);
1962- $versions{$item->{item}} = $version;
1963- }
1964- };
1965- if ( $EVAL_ERROR ) {
1966- PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
1967- }
1968- }
1969-
1970- return \%versions;
1971-}
1972-
1973-
1974-sub get_os_version {
1975- if ( $OSNAME eq 'MSWin32' ) {
1976- require Win32;
1977- return Win32::GetOSDisplayName();
1978- }
1979-
1980- chomp(my $platform = `uname -s`);
1981- PTDEBUG && _d('platform:', $platform);
1982- return $OSNAME unless $platform;
1983-
1984- chomp(my $lsb_release
1985- = `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
1986- PTDEBUG && _d('lsb_release:', $lsb_release);
1987-
1988- my $release = "";
1989-
1990- if ( $platform eq 'Linux' ) {
1991- if ( -f "/etc/fedora-release" ) {
1992- $release = `cat /etc/fedora-release`;
1993- }
1994- elsif ( -f "/etc/redhat-release" ) {
1995- $release = `cat /etc/redhat-release`;
1996- }
1997- elsif ( -f "/etc/system-release" ) {
1998- $release = `cat /etc/system-release`;
1999- }
2000- elsif ( $lsb_release ) {
2001- $release = `$lsb_release -ds`;
2002- }
2003- elsif ( -f "/etc/lsb-release" ) {
2004- $release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
2005- $release =~ s/^\w+="([^"]+)".+/$1/;
2006- }
2007- elsif ( -f "/etc/debian_version" ) {
2008- chomp(my $rel = `cat /etc/debian_version`);
2009- $release = "Debian $rel";
2010- if ( -f "/etc/apt/sources.list" ) {
2011- 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}'`);
2012- $release .= " ($code_name)" if $code_name;
2013- }
2014- }
2015- elsif ( -f "/etc/os-release" ) { # openSUSE
2016- chomp($release = `grep PRETTY_NAME /etc/os-release`);
2017- $release =~ s/^PRETTY_NAME="(.+)"$/$1/;
2018- }
2019- elsif ( `ls /etc/*release 2>/dev/null` ) {
2020- if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
2021- $release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
2022- }
2023- else {
2024- $release = `cat /etc/*release | head -n1`;
2025- }
2026- }
2027- }
2028- elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
2029- my $rel = `uname -r`;
2030- $release = "$platform $rel";
2031- }
2032- elsif ( $platform eq "SunOS" ) {
2033- my $rel = `head -n1 /etc/release` || `uname -r`;
2034- $release = "$platform $rel";
2035- }
2036-
2037- if ( !$release ) {
2038- PTDEBUG && _d('Failed to get the release, using platform');
2039- $release = $platform;
2040- }
2041- chomp($release);
2042-
2043- $release =~ s/^"|"$//g;
2044-
2045- PTDEBUG && _d('OS version =', $release);
2046- return $release;
2047-}
2048-
2049-sub get_perl_version {
2050- my (%args) = @_;
2051- my $item = $args{item};
2052- return unless $item;
2053-
2054- my $version = sprintf '%vd', $PERL_VERSION;
2055- PTDEBUG && _d('Perl version', $version);
2056- return $version;
2057-}
2058-
2059-sub get_perl_module_version {
2060- my (%args) = @_;
2061- my $item = $args{item};
2062- return unless $item;
2063-
2064- my $var = '$' . $item->{item} . '::VERSION';
2065- my $version = eval "use $item->{item}; $var;";
2066- PTDEBUG && _d('Perl version for', $var, '=', $version);
2067- return $version;
2068-}
2069-
2070-sub get_mysql_variable {
2071- return get_from_mysql(
2072- show => 'VARIABLES',
2073- @_,
2074- );
2075-}
2076-
2077-sub get_from_mysql {
2078- my (%args) = @_;
2079- my $show = $args{show};
2080- my $item = $args{item};
2081- my $instances = $args{instances};
2082- return unless $show && $item;
2083-
2084- if ( !$instances || !@$instances ) {
2085- PTDEBUG && _d('Cannot check', $item,
2086- 'because there are no MySQL instances');
2087- return;
2088- }
2089-
2090- my @versions;
2091- my %version_for;
2092- foreach my $instance ( @$instances ) {
2093- next unless $instance->{id}; # special system instance has id=0
2094- my $dbh = $instance->{dbh};
2095- local $dbh->{FetchHashKeyName} = 'NAME_lc';
2096- my $sql = qq/SHOW $show/;
2097- PTDEBUG && _d($sql);
2098- my $rows = $dbh->selectall_hashref($sql, 'variable_name');
2099-
2100- my @versions;
2101- foreach my $var ( @{$item->{vars}} ) {
2102- $var = lc($var);
2103- my $version = $rows->{$var}->{value};
2104- PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
2105- 'on', $instance->{name});
2106- push @versions, $version;
2107- }
2108- $version_for{ $instance->{id} } = join(' ', @versions);
2109- }
2110-
2111- return \%version_for;
2112-}
2113-
2114-sub _d {
2115- my ($package, undef, $line) = caller 0;
2116- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2117- map { defined $_ ? $_ : 'undef' }
2118- @_;
2119- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2120-}
2121-
2122-1;
2123-}
2124-# ###########################################################################
2125-# End VersionCheck package
2126-# ###########################################################################
2127-
2128-# ###########################################################################
2129-# DSNParser package
2130-# This package is a copy without comments from the original. The original
2131-# with comments and its test file can be found in the Bazaar repository at,
2132-# lib/DSNParser.pm
2133-# t/lib/DSNParser.t
2134-# See https://launchpad.net/percona-toolkit for more information.
2135-# ###########################################################################
2136-{
2137-package DSNParser;
2138-
2139-use strict;
2140-use warnings FATAL => 'all';
2141-use English qw(-no_match_vars);
2142-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2143-
2144-use Data::Dumper;
2145-$Data::Dumper::Indent = 0;
2146-$Data::Dumper::Quotekeys = 0;
2147-
2148-my $dsn_sep = qr/(?<!\\),/;
2149-
2150-eval {
2151- require DBI;
2152-};
2153-my $have_dbi = $EVAL_ERROR ? 0 : 1;
2154-
2155-sub new {
2156- my ( $class, %args ) = @_;
2157- foreach my $arg ( qw(opts) ) {
2158- die "I need a $arg argument" unless $args{$arg};
2159- }
2160- my $self = {
2161- opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
2162- };
2163- foreach my $opt ( @{$args{opts}} ) {
2164- if ( !$opt->{key} || !$opt->{desc} ) {
2165- die "Invalid DSN option: ", Dumper($opt);
2166- }
2167- PTDEBUG && _d('DSN option:',
2168- join(', ',
2169- map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
2170- keys %$opt
2171- )
2172- );
2173- $self->{opts}->{$opt->{key}} = {
2174- dsn => $opt->{dsn},
2175- desc => $opt->{desc},
2176- copy => $opt->{copy} || 0,
2177- };
2178- }
2179- return bless $self, $class;
2180-}
2181-
2182-sub prop {
2183- my ( $self, $prop, $value ) = @_;
2184- if ( @_ > 2 ) {
2185- PTDEBUG && _d('Setting', $prop, 'property');
2186- $self->{$prop} = $value;
2187- }
2188- return $self->{$prop};
2189-}
2190-
2191-sub parse {
2192- my ( $self, $dsn, $prev, $defaults ) = @_;
2193- if ( !$dsn ) {
2194- PTDEBUG && _d('No DSN to parse');
2195- return;
2196- }
2197- PTDEBUG && _d('Parsing', $dsn);
2198- $prev ||= {};
2199- $defaults ||= {};
2200- my %given_props;
2201- my %final_props;
2202- my $opts = $self->{opts};
2203-
2204- foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
2205- $dsn_part =~ s/\\,/,/g;
2206- if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
2207- $given_props{$prop_key} = $prop_val;
2208- }
2209- else {
2210- PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
2211- $given_props{h} = $dsn_part;
2212- }
2213- }
2214-
2215- foreach my $key ( keys %$opts ) {
2216- PTDEBUG && _d('Finding value for', $key);
2217- $final_props{$key} = $given_props{$key};
2218- if ( !defined $final_props{$key}
2219- && defined $prev->{$key} && $opts->{$key}->{copy} )
2220- {
2221- $final_props{$key} = $prev->{$key};
2222- PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
2223- }
2224- if ( !defined $final_props{$key} ) {
2225- $final_props{$key} = $defaults->{$key};
2226- PTDEBUG && _d('Copying value for', $key, 'from defaults');
2227- }
2228- }
2229-
2230- foreach my $key ( keys %given_props ) {
2231- die "Unknown DSN option '$key' in '$dsn'. For more details, "
2232- . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
2233- . "for complete documentation."
2234- unless exists $opts->{$key};
2235- }
2236- if ( (my $required = $self->prop('required')) ) {
2237- foreach my $key ( keys %$required ) {
2238- die "Missing required DSN option '$key' in '$dsn'. For more details, "
2239- . "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
2240- . "for complete documentation."
2241- unless $final_props{$key};
2242- }
2243- }
2244-
2245- return \%final_props;
2246-}
2247-
2248-sub parse_options {
2249- my ( $self, $o ) = @_;
2250- die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
2251- my $dsn_string
2252- = join(',',
2253- map { "$_=".$o->get($_); }
2254- grep { $o->has($_) && $o->get($_) }
2255- keys %{$self->{opts}}
2256- );
2257- PTDEBUG && _d('DSN string made from options:', $dsn_string);
2258- return $self->parse($dsn_string);
2259-}
2260-
2261-sub as_string {
2262- my ( $self, $dsn, $props ) = @_;
2263- return $dsn unless ref $dsn;
2264- my @keys = $props ? @$props : sort keys %$dsn;
2265- return join(',',
2266- map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
2267- grep {
2268- exists $self->{opts}->{$_}
2269- && exists $dsn->{$_}
2270- && defined $dsn->{$_}
2271- } @keys);
2272-}
2273-
2274-sub usage {
2275- my ( $self ) = @_;
2276- my $usage
2277- = "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
2278- . " KEY COPY MEANING\n"
2279- . " === ==== =============================================\n";
2280- my %opts = %{$self->{opts}};
2281- foreach my $key ( sort keys %opts ) {
2282- $usage .= " $key "
2283- . ($opts{$key}->{copy} ? 'yes ' : 'no ')
2284- . ($opts{$key}->{desc} || '[No description]')
2285- . "\n";
2286- }
2287- $usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
2288- return $usage;
2289-}
2290-
2291-sub get_cxn_params {
2292- my ( $self, $info ) = @_;
2293- my $dsn;
2294- my %opts = %{$self->{opts}};
2295- my $driver = $self->prop('dbidriver') || '';
2296- if ( $driver eq 'Pg' ) {
2297- $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
2298- . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
2299- grep { defined $info->{$_} }
2300- qw(h P));
2301- }
2302- else {
2303- $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
2304- . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
2305- grep { defined $info->{$_} }
2306- qw(F h P S A))
2307- . ';mysql_read_default_group=client'
2308- . ($info->{L} ? ';mysql_local_infile=1' : '');
2309- }
2310- PTDEBUG && _d($dsn);
2311- return ($dsn, $info->{u}, $info->{p});
2312-}
2313-
2314-sub fill_in_dsn {
2315- my ( $self, $dbh, $dsn ) = @_;
2316- my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
2317- my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
2318- $user =~ s/@.*//;
2319- $dsn->{h} ||= $vars->{hostname}->{Value};
2320- $dsn->{S} ||= $vars->{'socket'}->{Value};
2321- $dsn->{P} ||= $vars->{port}->{Value};
2322- $dsn->{u} ||= $user;
2323- $dsn->{D} ||= $db;
2324-}
2325-
2326-sub get_dbh {
2327- my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
2328- $opts ||= {};
2329- my $defaults = {
2330- AutoCommit => 0,
2331- RaiseError => 1,
2332- PrintError => 0,
2333- ShowErrorStatement => 1,
2334- mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
2335- };
2336- @{$defaults}{ keys %$opts } = values %$opts;
2337- if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
2338- $defaults->{mysql_local_infile} = 1;
2339- }
2340-
2341- if ( $opts->{mysql_use_result} ) {
2342- $defaults->{mysql_use_result} = 1;
2343- }
2344-
2345- if ( !$have_dbi ) {
2346- die "Cannot connect to MySQL because the Perl DBI module is not "
2347- . "installed or not found. Run 'perl -MDBI' to see the directories "
2348- . "that Perl searches for DBI. If DBI is not installed, try:\n"
2349- . " Debian/Ubuntu apt-get install libdbi-perl\n"
2350- . " RHEL/CentOS yum install perl-DBI\n"
2351- . " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
2352-
2353- }
2354-
2355- my $dbh;
2356- my $tries = 2;
2357- while ( !$dbh && $tries-- ) {
2358- PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
2359- join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
2360-
2361- $dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
2362-
2363- if ( !$dbh && $EVAL_ERROR ) {
2364- if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
2365- die "Cannot connect to MySQL because the Perl DBD::mysql module is "
2366- . "not installed or not found. Run 'perl -MDBD::mysql' to see "
2367- . "the directories that Perl searches for DBD::mysql. If "
2368- . "DBD::mysql is not installed, try:\n"
2369- . " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
2370- . " RHEL/CentOS yum install perl-DBD-MySQL\n"
2371- . " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
2372- }
2373- elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
2374- PTDEBUG && _d('Going to try again without utf8 support');
2375- delete $defaults->{mysql_enable_utf8};
2376- }
2377- if ( !$tries ) {
2378- die $EVAL_ERROR;
2379- }
2380- }
2381- }
2382-
2383- if ( $cxn_string =~ m/mysql/i ) {
2384- my $sql;
2385-
2386- $sql = 'SELECT @@SQL_MODE';
2387- PTDEBUG && _d($dbh, $sql);
2388- my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
2389- if ( $EVAL_ERROR ) {
2390- die "Error getting the current SQL_MODE: $EVAL_ERROR";
2391- }
2392-
2393- if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
2394- $sql = qq{/*!40101 SET NAMES "$charset"*/};
2395- PTDEBUG && _d($dbh, $sql);
2396- eval { $dbh->do($sql) };
2397- if ( $EVAL_ERROR ) {
2398- die "Error setting NAMES to $charset: $EVAL_ERROR";
2399- }
2400- PTDEBUG && _d('Enabling charset for STDOUT');
2401- if ( $charset eq 'utf8' ) {
2402- binmode(STDOUT, ':utf8')
2403- or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
2404- }
2405- else {
2406- binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
2407- }
2408- }
2409-
2410- if ( my $vars = $self->prop('set-vars') ) {
2411- $self->set_vars($dbh, $vars);
2412- }
2413-
2414- $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
2415- . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
2416- . ($sql_mode ? ",$sql_mode" : '')
2417- . '\'*/';
2418- PTDEBUG && _d($dbh, $sql);
2419- eval { $dbh->do($sql) };
2420- if ( $EVAL_ERROR ) {
2421- die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
2422- . ($sql_mode ? " and $sql_mode" : '')
2423- . ": $EVAL_ERROR";
2424- }
2425- }
2426-
2427- PTDEBUG && _d('DBH info: ',
2428- $dbh,
2429- Dumper($dbh->selectrow_hashref(
2430- 'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
2431- 'Connection info:', $dbh->{mysql_hostinfo},
2432- 'Character set info:', Dumper($dbh->selectall_arrayref(
2433- "SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
2434- '$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
2435- '$DBI::VERSION:', $DBI::VERSION,
2436- );
2437-
2438- return $dbh;
2439-}
2440-
2441-sub get_hostname {
2442- my ( $self, $dbh ) = @_;
2443- if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
2444- return $host;
2445- }
2446- my ( $hostname, $one ) = $dbh->selectrow_array(
2447- 'SELECT /*!50038 @@hostname, */ 1');
2448- return $hostname;
2449-}
2450-
2451-sub disconnect {
2452- my ( $self, $dbh ) = @_;
2453- PTDEBUG && $self->print_active_handles($dbh);
2454- $dbh->disconnect;
2455-}
2456-
2457-sub print_active_handles {
2458- my ( $self, $thing, $level ) = @_;
2459- $level ||= 0;
2460- printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
2461- $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
2462- or die "Cannot print: $OS_ERROR";
2463- foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
2464- $self->print_active_handles( $handle, $level + 1 );
2465- }
2466-}
2467-
2468-sub copy {
2469- my ( $self, $dsn_1, $dsn_2, %args ) = @_;
2470- die 'I need a dsn_1 argument' unless $dsn_1;
2471- die 'I need a dsn_2 argument' unless $dsn_2;
2472- my %new_dsn = map {
2473- my $key = $_;
2474- my $val;
2475- if ( $args{overwrite} ) {
2476- $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
2477- }
2478- else {
2479- $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
2480- }
2481- $key => $val;
2482- } keys %{$self->{opts}};
2483- return \%new_dsn;
2484-}
2485-
2486-sub set_vars {
2487- my ($self, $dbh, $vars) = @_;
2488-
2489- return unless $vars;
2490-
2491- foreach my $var ( sort keys %$vars ) {
2492- my $val = $vars->{$var}->{val};
2493-
2494- (my $quoted_var = $var) =~ s/_/\\_/;
2495- my ($var_exists, $current_val);
2496- eval {
2497- ($var_exists, $current_val) = $dbh->selectrow_array(
2498- "SHOW VARIABLES LIKE '$quoted_var'");
2499- };
2500- my $e = $EVAL_ERROR;
2501- if ( $e ) {
2502- PTDEBUG && _d($e);
2503- }
2504-
2505- if ( $vars->{$var}->{default} && !$var_exists ) {
2506- PTDEBUG && _d('Not setting default var', $var,
2507- 'because it does not exist');
2508- next;
2509- }
2510-
2511- if ( $current_val && $current_val eq $val ) {
2512- PTDEBUG && _d('Not setting var', $var, 'because its value',
2513- 'is already', $val);
2514- next;
2515- }
2516-
2517- my $sql = "SET SESSION $var=$val";
2518- PTDEBUG && _d($dbh, $sql);
2519- eval { $dbh->do($sql) };
2520- if ( my $set_error = $EVAL_ERROR ) {
2521- chomp($set_error);
2522- $set_error =~ s/ at \S+ line \d+//;
2523- my $msg = "Error setting $var: $set_error";
2524- if ( $current_val ) {
2525- $msg .= " The current value for $var is $current_val. "
2526- . "If the variable is read only (not dynamic), specify "
2527- . "--set-vars $var=$current_val to avoid this warning, "
2528- . "else manually set the variable and restart MySQL.";
2529- }
2530- warn $msg . "\n\n";
2531- }
2532- }
2533-
2534- return;
2535-}
2536-
2537-sub _d {
2538- my ($package, undef, $line) = caller 0;
2539- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2540- map { defined $_ ? $_ : 'undef' }
2541- @_;
2542- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2543-}
2544-
2545-1;
2546-}
2547-# ###########################################################################
2548-# End DSNParser package
2549-# ###########################################################################
2550-
2551-# ###########################################################################
2552-# OptionParser package
2553-# This package is a copy without comments from the original. The original
2554-# with comments and its test file can be found in the Bazaar repository at,
2555-# lib/OptionParser.pm
2556-# t/lib/OptionParser.t
2557-# See https://launchpad.net/percona-toolkit for more information.
2558-# ###########################################################################
2559-{
2560-package OptionParser;
2561-
2562-use strict;
2563-use warnings FATAL => 'all';
2564-use English qw(-no_match_vars);
2565-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2566-
2567-use List::Util qw(max);
2568-use Getopt::Long;
2569-use Data::Dumper;
2570-
2571-my $POD_link_re = '[LC]<"?([^">]+)"?>';
2572-
2573-sub new {
2574- my ( $class, %args ) = @_;
2575- my @required_args = qw();
2576- foreach my $arg ( @required_args ) {
2577- die "I need a $arg argument" unless $args{$arg};
2578- }
2579-
2580- my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
2581- $program_name ||= $PROGRAM_NAME;
2582- my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
2583-
2584- my %attributes = (
2585- 'type' => 1,
2586- 'short form' => 1,
2587- 'group' => 1,
2588- 'default' => 1,
2589- 'cumulative' => 1,
2590- 'negatable' => 1,
2591- );
2592-
2593- my $self = {
2594- head1 => 'OPTIONS', # These args are used internally
2595- skip_rules => 0, # to instantiate another Option-
2596- item => '--(.*)', # Parser obj that parses the
2597- attributes => \%attributes, # DSN OPTIONS section. Tools
2598- parse_attributes => \&_parse_attribs, # don't tinker with these args.
2599-
2600- %args,
2601-
2602- strict => 1, # disabled by a special rule
2603- program_name => $program_name,
2604- opts => {},
2605- got_opts => 0,
2606- short_opts => {},
2607- defaults => {},
2608- groups => {},
2609- allowed_groups => {},
2610- errors => [],
2611- rules => [], # desc of rules for --help
2612- mutex => [], # rule: opts are mutually exclusive
2613- atleast1 => [], # rule: at least one opt is required
2614- disables => {}, # rule: opt disables other opts
2615- defaults_to => {}, # rule: opt defaults to value of other opt
2616- DSNParser => undef,
2617- default_files => [
2618- "/etc/percona-toolkit/percona-toolkit.conf",
2619- "/etc/percona-toolkit/$program_name.conf",
2620- "$home/.percona-toolkit.conf",
2621- "$home/.$program_name.conf",
2622- ],
2623- types => {
2624- string => 's', # standard Getopt type
2625- int => 'i', # standard Getopt type
2626- float => 'f', # standard Getopt type
2627- Hash => 'H', # hash, formed from a comma-separated list
2628- hash => 'h', # hash as above, but only if a value is given
2629- Array => 'A', # array, similar to Hash
2630- array => 'a', # array, similar to hash
2631- DSN => 'd', # DSN
2632- size => 'z', # size with kMG suffix (powers of 2^10)
2633- time => 'm', # time, with an optional suffix of s/h/m/d
2634- },
2635- };
2636-
2637- return bless $self, $class;
2638-}
2639-
2640-sub get_specs {
2641- my ( $self, $file ) = @_;
2642- $file ||= $self->{file} || __FILE__;
2643- my @specs = $self->_pod_to_specs($file);
2644- $self->_parse_specs(@specs);
2645-
2646- open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
2647- my $contents = do { local $/ = undef; <$fh> };
2648- close $fh;
2649- if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
2650- PTDEBUG && _d('Parsing DSN OPTIONS');
2651- my $dsn_attribs = {
2652- dsn => 1,
2653- copy => 1,
2654- };
2655- my $parse_dsn_attribs = sub {
2656- my ( $self, $option, $attribs ) = @_;
2657- map {
2658- my $val = $attribs->{$_};
2659- if ( $val ) {
2660- $val = $val eq 'yes' ? 1
2661- : $val eq 'no' ? 0
2662- : $val;
2663- $attribs->{$_} = $val;
2664- }
2665- } keys %$attribs;
2666- return {
2667- key => $option,
2668- %$attribs,
2669- };
2670- };
2671- my $dsn_o = new OptionParser(
2672- description => 'DSN OPTIONS',
2673- head1 => 'DSN OPTIONS',
2674- dsn => 0, # XXX don't infinitely recurse!
2675- item => '\* (.)', # key opts are a single character
2676- skip_rules => 1, # no rules before opts
2677- attributes => $dsn_attribs,
2678- parse_attributes => $parse_dsn_attribs,
2679- );
2680- my @dsn_opts = map {
2681- my $opts = {
2682- key => $_->{spec}->{key},
2683- dsn => $_->{spec}->{dsn},
2684- copy => $_->{spec}->{copy},
2685- desc => $_->{desc},
2686- };
2687- $opts;
2688- } $dsn_o->_pod_to_specs($file);
2689- $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
2690- }
2691-
2692- if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
2693- $self->{version} = $1;
2694- PTDEBUG && _d($self->{version});
2695- }
2696-
2697- return;
2698-}
2699-
2700-sub DSNParser {
2701- my ( $self ) = @_;
2702- return $self->{DSNParser};
2703-};
2704-
2705-sub get_defaults_files {
2706- my ( $self ) = @_;
2707- return @{$self->{default_files}};
2708-}
2709-
2710-sub _pod_to_specs {
2711- my ( $self, $file ) = @_;
2712- $file ||= $self->{file} || __FILE__;
2713- open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
2714-
2715- my @specs = ();
2716- my @rules = ();
2717- my $para;
2718-
2719- local $INPUT_RECORD_SEPARATOR = '';
2720- while ( $para = <$fh> ) {
2721- next unless $para =~ m/^=head1 $self->{head1}/;
2722- last;
2723- }
2724-
2725- while ( $para = <$fh> ) {
2726- last if $para =~ m/^=over/;
2727- next if $self->{skip_rules};
2728- chomp $para;
2729- $para =~ s/\s+/ /g;
2730- $para =~ s/$POD_link_re/$1/go;
2731- PTDEBUG && _d('Option rule:', $para);
2732- push @rules, $para;
2733- }
2734-
2735- die "POD has no $self->{head1} section" unless $para;
2736-
2737- do {
2738- if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
2739- chomp $para;
2740- PTDEBUG && _d($para);
2741- my %attribs;
2742-
2743- $para = <$fh>; # read next paragraph, possibly attributes
2744-
2745- if ( $para =~ m/: / ) { # attributes
2746- $para =~ s/\s+\Z//g;
2747- %attribs = map {
2748- my ( $attrib, $val) = split(/: /, $_);
2749- die "Unrecognized attribute for --$option: $attrib"
2750- unless $self->{attributes}->{$attrib};
2751- ($attrib, $val);
2752- } split(/; /, $para);
2753- if ( $attribs{'short form'} ) {
2754- $attribs{'short form'} =~ s/-//;
2755- }
2756- $para = <$fh>; # read next paragraph, probably short help desc
2757- }
2758- else {
2759- PTDEBUG && _d('Option has no attributes');
2760- }
2761-
2762- $para =~ s/\s+\Z//g;
2763- $para =~ s/\s+/ /g;
2764- $para =~ s/$POD_link_re/$1/go;
2765-
2766- $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
2767- PTDEBUG && _d('Short help:', $para);
2768-
2769- die "No description after option spec $option" if $para =~ m/^=item/;
2770-
2771- if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
2772- $option = $base_option;
2773- $attribs{'negatable'} = 1;
2774- }
2775-
2776- push @specs, {
2777- spec => $self->{parse_attributes}->($self, $option, \%attribs),
2778- desc => $para
2779- . (defined $attribs{default} ? " (default $attribs{default})" : ''),
2780- group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
2781- };
2782- }
2783- while ( $para = <$fh> ) {
2784- last unless $para;
2785- if ( $para =~ m/^=head1/ ) {
2786- $para = undef; # Can't 'last' out of a do {} block.
2787- last;
2788- }
2789- last if $para =~ m/^=item /;
2790- }
2791- } while ( $para );
2792-
2793- die "No valid specs in $self->{head1}" unless @specs;
2794-
2795- close $fh;
2796- return @specs, @rules;
2797-}
2798-
2799-sub _parse_specs {
2800- my ( $self, @specs ) = @_;
2801- my %disables; # special rule that requires deferred checking
2802-
2803- foreach my $opt ( @specs ) {
2804- if ( ref $opt ) { # It's an option spec, not a rule.
2805- PTDEBUG && _d('Parsing opt spec:',
2806- map { ($_, '=>', $opt->{$_}) } keys %$opt);
2807-
2808- my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
2809- if ( !$long ) {
2810- die "Cannot parse long option from spec $opt->{spec}";
2811- }
2812- $opt->{long} = $long;
2813-
2814- die "Duplicate long option --$long" if exists $self->{opts}->{$long};
2815- $self->{opts}->{$long} = $opt;
2816-
2817- if ( length $long == 1 ) {
2818- PTDEBUG && _d('Long opt', $long, 'looks like short opt');
2819- $self->{short_opts}->{$long} = $long;
2820- }
2821-
2822- if ( $short ) {
2823- die "Duplicate short option -$short"
2824- if exists $self->{short_opts}->{$short};
2825- $self->{short_opts}->{$short} = $long;
2826- $opt->{short} = $short;
2827- }
2828- else {
2829- $opt->{short} = undef;
2830- }
2831-
2832- $opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
2833- $opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
2834- $opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
2835-
2836- $opt->{group} ||= 'default';
2837- $self->{groups}->{ $opt->{group} }->{$long} = 1;
2838-
2839- $opt->{value} = undef;
2840- $opt->{got} = 0;
2841-
2842- my ( $type ) = $opt->{spec} =~ m/=(.)/;
2843- $opt->{type} = $type;
2844- PTDEBUG && _d($long, 'type:', $type);
2845-
2846-
2847- $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
2848-
2849- if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
2850- $self->{defaults}->{$long} = defined $def ? $def : 1;
2851- PTDEBUG && _d($long, 'default:', $def);
2852- }
2853-
2854- if ( $long eq 'config' ) {
2855- $self->{defaults}->{$long} = join(',', $self->get_defaults_files());
2856- }
2857-
2858- if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
2859- $disables{$long} = $dis;
2860- PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
2861- }
2862-
2863- $self->{opts}->{$long} = $opt;
2864- }
2865- else { # It's an option rule, not a spec.
2866- PTDEBUG && _d('Parsing rule:', $opt);
2867- push @{$self->{rules}}, $opt;
2868- my @participants = $self->_get_participants($opt);
2869- my $rule_ok = 0;
2870-
2871- if ( $opt =~ m/mutually exclusive|one and only one/ ) {
2872- $rule_ok = 1;
2873- push @{$self->{mutex}}, \@participants;
2874- PTDEBUG && _d(@participants, 'are mutually exclusive');
2875- }
2876- if ( $opt =~ m/at least one|one and only one/ ) {
2877- $rule_ok = 1;
2878- push @{$self->{atleast1}}, \@participants;
2879- PTDEBUG && _d(@participants, 'require at least one');
2880- }
2881- if ( $opt =~ m/default to/ ) {
2882- $rule_ok = 1;
2883- $self->{defaults_to}->{$participants[0]} = $participants[1];
2884- PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
2885- }
2886- if ( $opt =~ m/restricted to option groups/ ) {
2887- $rule_ok = 1;
2888- my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
2889- my @groups = split(',', $groups);
2890- %{$self->{allowed_groups}->{$participants[0]}} = map {
2891- s/\s+//;
2892- $_ => 1;
2893- } @groups;
2894- }
2895- if( $opt =~ m/accepts additional command-line arguments/ ) {
2896- $rule_ok = 1;
2897- $self->{strict} = 0;
2898- PTDEBUG && _d("Strict mode disabled by rule");
2899- }
2900-
2901- die "Unrecognized option rule: $opt" unless $rule_ok;
2902- }
2903- }
2904-
2905- foreach my $long ( keys %disables ) {
2906- my @participants = $self->_get_participants($disables{$long});
2907- $self->{disables}->{$long} = \@participants;
2908- PTDEBUG && _d('Option', $long, 'disables', @participants);
2909- }
2910-
2911- return;
2912-}
2913-
2914-sub _get_participants {
2915- my ( $self, $str ) = @_;
2916- my @participants;
2917- foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
2918- die "Option --$long does not exist while processing rule $str"
2919- unless exists $self->{opts}->{$long};
2920- push @participants, $long;
2921- }
2922- PTDEBUG && _d('Participants for', $str, ':', @participants);
2923- return @participants;
2924-}
2925-
2926-sub opts {
2927- my ( $self ) = @_;
2928- my %opts = %{$self->{opts}};
2929- return %opts;
2930-}
2931-
2932-sub short_opts {
2933- my ( $self ) = @_;
2934- my %short_opts = %{$self->{short_opts}};
2935- return %short_opts;
2936-}
2937-
2938-sub set_defaults {
2939- my ( $self, %defaults ) = @_;
2940- $self->{defaults} = {};
2941- foreach my $long ( keys %defaults ) {
2942- die "Cannot set default for nonexistent option $long"
2943- unless exists $self->{opts}->{$long};
2944- $self->{defaults}->{$long} = $defaults{$long};
2945- PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
2946- }
2947- return;
2948-}
2949-
2950-sub get_defaults {
2951- my ( $self ) = @_;
2952- return $self->{defaults};
2953-}
2954-
2955-sub get_groups {
2956- my ( $self ) = @_;
2957- return $self->{groups};
2958-}
2959-
2960-sub _set_option {
2961- my ( $self, $opt, $val ) = @_;
2962- my $long = exists $self->{opts}->{$opt} ? $opt
2963- : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
2964- : die "Getopt::Long gave a nonexistent option: $opt";
2965- $opt = $self->{opts}->{$long};
2966- if ( $opt->{is_cumulative} ) {
2967- $opt->{value}++;
2968- }
2969- elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
2970- my $next_opt = $1;
2971- if ( exists $self->{opts}->{$next_opt}
2972- || exists $self->{short_opts}->{$next_opt} ) {
2973- $self->save_error("--$long requires a string value");
2974- return;
2975- }
2976- else {
2977- $opt->{value} = $val;
2978- }
2979- }
2980- else {
2981- $opt->{value} = $val;
2982- }
2983- $opt->{got} = 1;
2984- PTDEBUG && _d('Got option', $long, '=', $val);
2985-}
2986-
2987-sub get_opts {
2988- my ( $self ) = @_;
2989-
2990- foreach my $long ( keys %{$self->{opts}} ) {
2991- $self->{opts}->{$long}->{got} = 0;
2992- $self->{opts}->{$long}->{value}
2993- = exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
2994- : $self->{opts}->{$long}->{is_cumulative} ? 0
2995- : undef;
2996- }
2997- $self->{got_opts} = 0;
2998-
2999- $self->{errors} = [];
3000-
3001- if ( @ARGV && $ARGV[0] eq "--config" ) {
3002- shift @ARGV;
3003- $self->_set_option('config', shift @ARGV);
3004- }
3005- if ( $self->has('config') ) {
3006- my @extra_args;
3007- foreach my $filename ( split(',', $self->get('config')) ) {
3008- eval {
3009- push @extra_args, $self->_read_config_file($filename);
3010- };
3011- if ( $EVAL_ERROR ) {
3012- if ( $self->got('config') ) {
3013- die $EVAL_ERROR;
3014- }
3015- elsif ( PTDEBUG ) {
3016- _d($EVAL_ERROR);
3017- }
3018- }
3019- }
3020- unshift @ARGV, @extra_args;
3021- }
3022-
3023- Getopt::Long::Configure('no_ignore_case', 'bundling');
3024- GetOptions(
3025- map { $_->{spec} => sub { $self->_set_option(@_); } }
3026- grep { $_->{long} ne 'config' } # --config is handled specially above.
3027- values %{$self->{opts}}
3028- ) or $self->save_error('Error parsing options');
3029-
3030- if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
3031- if ( $self->{version} ) {
3032- print $self->{version}, "\n";
3033- }
3034- else {
3035- print "Error parsing version. See the VERSION section of the tool's documentation.\n";
3036- }
3037- exit 1;
3038- }
3039-
3040- if ( @ARGV && $self->{strict} ) {
3041- $self->save_error("Unrecognized command-line options @ARGV");
3042- }
3043-
3044- foreach my $mutex ( @{$self->{mutex}} ) {
3045- my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
3046- if ( @set > 1 ) {
3047- my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
3048- @{$mutex}[ 0 .. scalar(@$mutex) - 2] )
3049- . ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
3050- . ' are mutually exclusive.';
3051- $self->save_error($err);
3052- }
3053- }
3054-
3055- foreach my $required ( @{$self->{atleast1}} ) {
3056- my @set = grep { $self->{opts}->{$_}->{got} } @$required;
3057- if ( @set == 0 ) {
3058- my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
3059- @{$required}[ 0 .. scalar(@$required) - 2] )
3060- .' or --'.$self->{opts}->{$required->[-1]}->{long};
3061- $self->save_error("Specify at least one of $err");
3062- }
3063- }
3064-
3065- $self->_check_opts( keys %{$self->{opts}} );
3066- $self->{got_opts} = 1;
3067- return;
3068-}
3069-
3070-sub _check_opts {
3071- my ( $self, @long ) = @_;
3072- my $long_last = scalar @long;
3073- while ( @long ) {
3074- foreach my $i ( 0..$#long ) {
3075- my $long = $long[$i];
3076- next unless $long;
3077- my $opt = $self->{opts}->{$long};
3078- if ( $opt->{got} ) {
3079- if ( exists $self->{disables}->{$long} ) {
3080- my @disable_opts = @{$self->{disables}->{$long}};
3081- map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
3082- PTDEBUG && _d('Unset options', @disable_opts,
3083- 'because', $long,'disables them');
3084- }
3085-
3086- if ( exists $self->{allowed_groups}->{$long} ) {
3087-
3088- my @restricted_groups = grep {
3089- !exists $self->{allowed_groups}->{$long}->{$_}
3090- } keys %{$self->{groups}};
3091-
3092- my @restricted_opts;
3093- foreach my $restricted_group ( @restricted_groups ) {
3094- RESTRICTED_OPT:
3095- foreach my $restricted_opt (
3096- keys %{$self->{groups}->{$restricted_group}} )
3097- {
3098- next RESTRICTED_OPT if $restricted_opt eq $long;
3099- push @restricted_opts, $restricted_opt
3100- if $self->{opts}->{$restricted_opt}->{got};
3101- }
3102- }
3103-
3104- if ( @restricted_opts ) {
3105- my $err;
3106- if ( @restricted_opts == 1 ) {
3107- $err = "--$restricted_opts[0]";
3108- }
3109- else {
3110- $err = join(', ',
3111- map { "--$self->{opts}->{$_}->{long}" }
3112- grep { $_ }
3113- @restricted_opts[0..scalar(@restricted_opts) - 2]
3114- )
3115- . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
3116- }
3117- $self->save_error("--$long is not allowed with $err");
3118- }
3119- }
3120-
3121- }
3122- elsif ( $opt->{is_required} ) {
3123- $self->save_error("Required option --$long must be specified");
3124- }
3125-
3126- $self->_validate_type($opt);
3127- if ( $opt->{parsed} ) {
3128- delete $long[$i];
3129- }
3130- else {
3131- PTDEBUG && _d('Temporarily failed to parse', $long);
3132- }
3133- }
3134-
3135- die "Failed to parse options, possibly due to circular dependencies"
3136- if @long == $long_last;
3137- $long_last = @long;
3138- }
3139-
3140- return;
3141-}
3142-
3143-sub _validate_type {
3144- my ( $self, $opt ) = @_;
3145- return unless $opt;
3146-
3147- if ( !$opt->{type} ) {
3148- $opt->{parsed} = 1;
3149- return;
3150- }
3151-
3152- my $val = $opt->{value};
3153-
3154- if ( $val && $opt->{type} eq 'm' ) { # type time
3155- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
3156- my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
3157- if ( !$suffix ) {
3158- my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
3159- $suffix = $s || 's';
3160- PTDEBUG && _d('No suffix given; using', $suffix, 'for',
3161- $opt->{long}, '(value:', $val, ')');
3162- }
3163- if ( $suffix =~ m/[smhd]/ ) {
3164- $val = $suffix eq 's' ? $num # Seconds
3165- : $suffix eq 'm' ? $num * 60 # Minutes
3166- : $suffix eq 'h' ? $num * 3600 # Hours
3167- : $num * 86400; # Days
3168- $opt->{value} = ($prefix || '') . $val;
3169- PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
3170- }
3171- else {
3172- $self->save_error("Invalid time suffix for --$opt->{long}");
3173- }
3174- }
3175- elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
3176- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
3177- my $prev = {};
3178- my $from_key = $self->{defaults_to}->{ $opt->{long} };
3179- if ( $from_key ) {
3180- PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
3181- if ( $self->{opts}->{$from_key}->{parsed} ) {
3182- $prev = $self->{opts}->{$from_key}->{value};
3183- }
3184- else {
3185- PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
3186- $from_key, 'parsed');
3187- return;
3188- }
3189- }
3190- my $defaults = $self->{DSNParser}->parse_options($self);
3191- $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
3192- }
3193- elsif ( $val && $opt->{type} eq 'z' ) { # type size
3194- PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
3195- $self->_parse_size($opt, $val);
3196- }
3197- elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
3198- $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
3199- }
3200- elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
3201- $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
3202- }
3203- else {
3204- PTDEBUG && _d('Nothing to validate for option',
3205- $opt->{long}, 'type', $opt->{type}, 'value', $val);
3206- }
3207-
3208- $opt->{parsed} = 1;
3209- return;
3210-}
3211-
3212-sub get {
3213- my ( $self, $opt ) = @_;
3214- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3215- die "Option $opt does not exist"
3216- unless $long && exists $self->{opts}->{$long};
3217- return $self->{opts}->{$long}->{value};
3218-}
3219-
3220-sub got {
3221- my ( $self, $opt ) = @_;
3222- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3223- die "Option $opt does not exist"
3224- unless $long && exists $self->{opts}->{$long};
3225- return $self->{opts}->{$long}->{got};
3226-}
3227-
3228-sub has {
3229- my ( $self, $opt ) = @_;
3230- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3231- return defined $long ? exists $self->{opts}->{$long} : 0;
3232-}
3233-
3234-sub set {
3235- my ( $self, $opt, $val ) = @_;
3236- my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
3237- die "Option $opt does not exist"
3238- unless $long && exists $self->{opts}->{$long};
3239- $self->{opts}->{$long}->{value} = $val;
3240- return;
3241-}
3242-
3243-sub save_error {
3244- my ( $self, $error ) = @_;
3245- push @{$self->{errors}}, $error;
3246- return;
3247-}
3248-
3249-sub errors {
3250- my ( $self ) = @_;
3251- return $self->{errors};
3252-}
3253-
3254-sub usage {
3255- my ( $self ) = @_;
3256- warn "No usage string is set" unless $self->{usage}; # XXX
3257- return "Usage: " . ($self->{usage} || '') . "\n";
3258-}
3259-
3260-sub descr {
3261- my ( $self ) = @_;
3262- warn "No description string is set" unless $self->{description}; # XXX
3263- my $descr = ($self->{description} || $self->{program_name} || '')
3264- . " For more details, please use the --help option, "
3265- . "or try 'perldoc $PROGRAM_NAME' "
3266- . "for complete documentation.";
3267- $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
3268- unless $ENV{DONT_BREAK_LINES};
3269- $descr =~ s/ +$//mg;
3270- return $descr;
3271-}
3272-
3273-sub usage_or_errors {
3274- my ( $self, $file, $return ) = @_;
3275- $file ||= $self->{file} || __FILE__;
3276-
3277- if ( !$self->{description} || !$self->{usage} ) {
3278- PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
3279- my %synop = $self->_parse_synopsis($file);
3280- $self->{description} ||= $synop{description};
3281- $self->{usage} ||= $synop{usage};
3282- PTDEBUG && _d("Description:", $self->{description},
3283- "\nUsage:", $self->{usage});
3284- }
3285-
3286- if ( $self->{opts}->{help}->{got} ) {
3287- print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
3288- exit 0 unless $return;
3289- }
3290- elsif ( scalar @{$self->{errors}} ) {
3291- print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
3292- exit 1 unless $return;
3293- }
3294-
3295- return;
3296-}
3297-
3298-sub print_errors {
3299- my ( $self ) = @_;
3300- my $usage = $self->usage() . "\n";
3301- if ( (my @errors = @{$self->{errors}}) ) {
3302- $usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
3303- . "\n";
3304- }
3305- return $usage . "\n" . $self->descr();
3306-}
3307-
3308-sub print_usage {
3309- my ( $self ) = @_;
3310- die "Run get_opts() before print_usage()" unless $self->{got_opts};
3311- my @opts = values %{$self->{opts}};
3312-
3313- my $maxl = max(
3314- map {
3315- length($_->{long}) # option long name
3316- + ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
3317- + ($_->{type} ? 2 : 0) # "=x" where x is the opt type
3318- }
3319- @opts);
3320-
3321- my $maxs = max(0,
3322- map {
3323- length($_)
3324- + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
3325- + ($self->{opts}->{$_}->{type} ? 2 : 0)
3326- }
3327- values %{$self->{short_opts}});
3328-
3329- my $lcol = max($maxl, ($maxs + 3));
3330- my $rcol = 80 - $lcol - 6;
3331- my $rpad = ' ' x ( 80 - $rcol );
3332-
3333- $maxs = max($lcol - 3, $maxs);
3334-
3335- my $usage = $self->descr() . "\n" . $self->usage();
3336-
3337- my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
3338- push @groups, 'default';
3339-
3340- foreach my $group ( reverse @groups ) {
3341- $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
3342- foreach my $opt (
3343- sort { $a->{long} cmp $b->{long} }
3344- grep { $_->{group} eq $group }
3345- @opts )
3346- {
3347- my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
3348- my $short = $opt->{short};
3349- my $desc = $opt->{desc};
3350-
3351- $long .= $opt->{type} ? "=$opt->{type}" : "";
3352-
3353- if ( $opt->{type} && $opt->{type} eq 'm' ) {
3354- my ($s) = $desc =~ m/\(suffix (.)\)/;
3355- $s ||= 's';
3356- $desc =~ s/\s+\(suffix .\)//;
3357- $desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
3358- . "d=days; if no suffix, $s is used.";
3359- }
3360- $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
3361- $desc =~ s/ +$//mg;
3362- if ( $short ) {
3363- $usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
3364- }
3365- else {
3366- $usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
3367- }
3368- }
3369- }
3370-
3371- $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
3372-
3373- if ( (my @rules = @{$self->{rules}}) ) {
3374- $usage .= "\nRules:\n\n";
3375- $usage .= join("\n", map { " $_" } @rules) . "\n";
3376- }
3377- if ( $self->{DSNParser} ) {
3378- $usage .= "\n" . $self->{DSNParser}->usage();
3379- }
3380- $usage .= "\nOptions and values after processing arguments:\n\n";
3381- foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
3382- my $val = $opt->{value};
3383- my $type = $opt->{type} || '';
3384- my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
3385- $val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
3386- : !defined $val ? '(No value)'
3387- : $type eq 'd' ? $self->{DSNParser}->as_string($val)
3388- : $type =~ m/H|h/ ? join(',', sort keys %$val)
3389- : $type =~ m/A|a/ ? join(',', @$val)
3390- : $val;
3391- $usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
3392- }
3393- return $usage;
3394-}
3395-
3396-sub prompt_noecho {
3397- shift @_ if ref $_[0] eq __PACKAGE__;
3398- my ( $prompt ) = @_;
3399- local $OUTPUT_AUTOFLUSH = 1;
3400- print $prompt
3401- or die "Cannot print: $OS_ERROR";
3402- my $response;
3403- eval {
3404- require Term::ReadKey;
3405- Term::ReadKey::ReadMode('noecho');
3406- chomp($response = <STDIN>);
3407- Term::ReadKey::ReadMode('normal');
3408- print "\n"
3409- or die "Cannot print: $OS_ERROR";
3410- };
3411- if ( $EVAL_ERROR ) {
3412- die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
3413- }
3414- return $response;
3415-}
3416-
3417-sub _read_config_file {
3418- my ( $self, $filename ) = @_;
3419- open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
3420- my @args;
3421- my $prefix = '--';
3422- my $parse = 1;
3423-
3424- LINE:
3425- while ( my $line = <$fh> ) {
3426- chomp $line;
3427- next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
3428- $line =~ s/\s+#.*$//g;
3429- $line =~ s/^\s+|\s+$//g;
3430- if ( $line eq '--' ) {
3431- $prefix = '';
3432- $parse = 0;
3433- next LINE;
3434- }
3435- if ( $parse
3436- && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
3437- ) {
3438- push @args, grep { defined $_ } ("$prefix$opt", $arg);
3439- }
3440- elsif ( $line =~ m/./ ) {
3441- push @args, $line;
3442- }
3443- else {
3444- die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
3445- }
3446- }
3447- close $fh;
3448- return @args;
3449-}
3450-
3451-sub read_para_after {
3452- my ( $self, $file, $regex ) = @_;
3453- open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
3454- local $INPUT_RECORD_SEPARATOR = '';
3455- my $para;
3456- while ( $para = <$fh> ) {
3457- next unless $para =~ m/^=pod$/m;
3458- last;
3459- }
3460- while ( $para = <$fh> ) {
3461- next unless $para =~ m/$regex/;
3462- last;
3463- }
3464- $para = <$fh>;
3465- chomp($para);
3466- close $fh or die "Can't close $file: $OS_ERROR";
3467- return $para;
3468-}
3469-
3470-sub clone {
3471- my ( $self ) = @_;
3472-
3473- my %clone = map {
3474- my $hashref = $self->{$_};
3475- my $val_copy = {};
3476- foreach my $key ( keys %$hashref ) {
3477- my $ref = ref $hashref->{$key};
3478- $val_copy->{$key} = !$ref ? $hashref->{$key}
3479- : $ref eq 'HASH' ? { %{$hashref->{$key}} }
3480- : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
3481- : $hashref->{$key};
3482- }
3483- $_ => $val_copy;
3484- } qw(opts short_opts defaults);
3485-
3486- foreach my $scalar ( qw(got_opts) ) {
3487- $clone{$scalar} = $self->{$scalar};
3488- }
3489-
3490- return bless \%clone;
3491-}
3492-
3493-sub _parse_size {
3494- my ( $self, $opt, $val ) = @_;
3495-
3496- if ( lc($val || '') eq 'null' ) {
3497- PTDEBUG && _d('NULL size for', $opt->{long});
3498- $opt->{value} = 'null';
3499- return;
3500- }
3501-
3502- my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
3503- my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
3504- if ( defined $num ) {
3505- if ( $factor ) {
3506- $num *= $factor_for{$factor};
3507- PTDEBUG && _d('Setting option', $opt->{y},
3508- 'to num', $num, '* factor', $factor);
3509- }
3510- $opt->{value} = ($pre || '') . $num;
3511- }
3512- else {
3513- $self->save_error("Invalid size for --$opt->{long}: $val");
3514- }
3515- return;
3516-}
3517-
3518-sub _parse_attribs {
3519- my ( $self, $option, $attribs ) = @_;
3520- my $types = $self->{types};
3521- return $option
3522- . ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
3523- . ($attribs->{'negatable'} ? '!' : '' )
3524- . ($attribs->{'cumulative'} ? '+' : '' )
3525- . ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
3526-}
3527-
3528-sub _parse_synopsis {
3529- my ( $self, $file ) = @_;
3530- $file ||= $self->{file} || __FILE__;
3531- PTDEBUG && _d("Parsing SYNOPSIS in", $file);
3532-
3533- local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
3534- open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
3535- my $para;
3536- 1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
3537- die "$file does not contain a SYNOPSIS section" unless $para;
3538- my @synop;
3539- for ( 1..2 ) { # 1 for the usage, 2 for the description
3540- my $para = <$fh>;
3541- push @synop, $para;
3542- }
3543- close $fh;
3544- PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
3545- my ($usage, $desc) = @synop;
3546- die "The SYNOPSIS section in $file is not formatted properly"
3547- unless $usage && $desc;
3548-
3549- $usage =~ s/^\s*Usage:\s+(.+)/$1/;
3550- chomp $usage;
3551-
3552- $desc =~ s/\n/ /g;
3553- $desc =~ s/\s{2,}/ /g;
3554- $desc =~ s/\. ([A-Z][a-z])/. $1/g;
3555- $desc =~ s/\s+$//;
3556-
3557- return (
3558- description => $desc,
3559- usage => $usage,
3560- );
3561-};
3562-
3563-sub set_vars {
3564- my ($self, $file) = @_;
3565- $file ||= $self->{file} || __FILE__;
3566-
3567- my %user_vars;
3568- my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
3569- if ( $user_vars ) {
3570- foreach my $var_val ( @$user_vars ) {
3571- my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
3572- die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
3573- $user_vars{$var} = {
3574- val => $val,
3575- default => 0,
3576- };
3577- }
3578- }
3579-
3580- my %default_vars;
3581- my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
3582- if ( $default_vars ) {
3583- %default_vars = map {
3584- my $var_val = $_;
3585- my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
3586- die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
3587- $var => {
3588- val => $val,
3589- default => 1,
3590- };
3591- } split("\n", $default_vars);
3592- }
3593-
3594- my %vars = (
3595- %default_vars, # first the tool's defaults
3596- %user_vars, # then the user's which overwrite the defaults
3597- );
3598- PTDEBUG && _d('--set-vars:', Dumper(\%vars));
3599- return \%vars;
3600-}
3601-
3602-sub _d {
3603- my ($package, undef, $line) = caller 0;
3604- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3605- map { defined $_ ? $_ : 'undef' }
3606- @_;
3607- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3608-}
3609-
3610-if ( PTDEBUG ) {
3611- print STDERR '# ', $^X, ' ', $], "\n";
3612- if ( my $uname = `uname -a` ) {
3613- $uname =~ s/\s+/ /g;
3614- print STDERR "# $uname\n";
3615- }
3616- print STDERR '# Arguments: ',
3617- join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
3618-}
3619-
3620-1;
3621-}
3622-# ###########################################################################
3623-# End OptionParser package
3624-# ###########################################################################
3625-
3626-# ###########################################################################
3627-# Cxn package
3628-# This package is a copy without comments from the original. The original
3629-# with comments and its test file can be found in the Bazaar repository at,
3630-# lib/Cxn.pm
3631-# t/lib/Cxn.t
3632-# See https://launchpad.net/percona-toolkit for more information.
3633-# ###########################################################################
3634-{
3635-package Cxn;
3636-
3637-use strict;
3638-use warnings FATAL => 'all';
3639-use English qw(-no_match_vars);
3640-use Scalar::Util qw(blessed);
3641-use constant {
3642- PTDEBUG => $ENV{PTDEBUG} || 0,
3643- PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
3644-};
3645-
3646-sub new {
3647- my ( $class, %args ) = @_;
3648- my @required_args = qw(DSNParser OptionParser);
3649- foreach my $arg ( @required_args ) {
3650- die "I need a $arg argument" unless $args{$arg};
3651- };
3652- my ($dp, $o) = @args{@required_args};
3653-
3654- my $dsn_defaults = $dp->parse_options($o);
3655- my $prev_dsn = $args{prev_dsn};
3656- my $dsn = $args{dsn};
3657- if ( !$dsn ) {
3658- $args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
3659-
3660- $dsn = $dp->parse(
3661- $args{dsn_string}, $prev_dsn, $dsn_defaults);
3662- }
3663- elsif ( $prev_dsn ) {
3664- $dsn = $dp->copy($prev_dsn, $dsn);
3665- }
3666-
3667- my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
3668- || $dp->as_string($dsn, [qw(F)])
3669- || '';
3670-
3671- my $self = {
3672- dsn => $dsn,
3673- dbh => $args{dbh},
3674- dsn_name => $dsn_name,
3675- hostname => '',
3676- set => $args{set},
3677- NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
3678- dbh_set => 0,
3679- ask_pass => $args{ask_pass},
3680- DSNParser => $dp,
3681- is_cluster_node => undef,
3682- parent => $args{parent},
3683- };
3684-
3685- return bless $self, $class;
3686-}
3687-
3688-sub connect {
3689- my ( $self, %opts ) = @_;
3690- my $dsn = $opts{dsn} || $self->{dsn};
3691- my $dp = $self->{DSNParser};
3692-
3693- my $dbh = $self->{dbh};
3694- if ( !$dbh || !$dbh->ping() ) {
3695- if ( $self->{ask_pass} && !$self->{asked_for_pass} ) {
3696- $dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: ");
3697- $self->{asked_for_pass} = 1;
3698- }
3699- $dbh = $dp->get_dbh(
3700- $dp->get_cxn_params($dsn),
3701- {
3702- AutoCommit => 1,
3703- %opts,
3704- },
3705- );
3706- }
3707-
3708- $dbh = $self->set_dbh($dbh);
3709- if ( $opts{dsn} ) {
3710- $self->{dsn} = $dsn;
3711- $self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
3712- || $dp->as_string($dsn, [qw(F)])
3713- || '';
3714-
3715- }
3716- PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
3717- return $dbh;
3718-}
3719-
3720-sub set_dbh {
3721- my ($self, $dbh) = @_;
3722-
3723- if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
3724- PTDEBUG && _d($dbh, 'Already set dbh');
3725- return $dbh;
3726- }
3727-
3728- PTDEBUG && _d($dbh, 'Setting dbh');
3729-
3730- $dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
3731-
3732- my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/';
3733- PTDEBUG && _d($dbh, $sql);
3734- my ($server_id, $hostname) = $dbh->selectrow_array($sql);
3735- PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id);
3736- if ( $hostname ) {
3737- $self->{hostname} = $hostname;
3738- }
3739-
3740- if ( $self->{parent} ) {
3741- PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
3742- $dbh->{InactiveDestroy} = 1;
3743- }
3744-
3745- if ( my $set = $self->{set}) {
3746- $set->($dbh);
3747- }
3748-
3749- $self->{dbh} = $dbh;
3750- $self->{dbh_set} = 1;
3751- return $dbh;
3752-}
3753-
3754-sub lost_connection {
3755- my ($self, $e) = @_;
3756- return 0 unless $e;
3757- return $e =~ m/MySQL server has gone away/
3758- || $e =~ m/Lost connection to MySQL server/;
3759-}
3760-
3761-sub dbh {
3762- my ($self) = @_;
3763- return $self->{dbh};
3764-}
3765-
3766-sub dsn {
3767- my ($self) = @_;
3768- return $self->{dsn};
3769-}
3770-
3771-sub name {
3772- my ($self) = @_;
3773- return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
3774- return $self->{hostname} || $self->{dsn_name} || 'unknown host';
3775-}
3776-
3777-sub remove_duplicate_cxns {
3778- my ($self, %args) = @_;
3779- my @cxns = @{$args{cxns}};
3780- my $seen_ids = $args{seen_ids} || {};
3781- PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns));
3782- my @trimmed_cxns;
3783-
3784- for my $cxn ( @cxns ) {
3785- my $dbh = $cxn->dbh();
3786- my $sql = q{SELECT @@server_id};
3787- PTDEBUG && _d($sql);
3788- my ($id) = $dbh->selectrow_array($sql);
3789- PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
3790-
3791- if ( ! $seen_ids->{$id}++ ) {
3792- push @trimmed_cxns, $cxn
3793- }
3794- else {
3795- PTDEBUG && _d("Removing ", $cxn->name,
3796- ", ID ", $id, ", because we've already seen it");
3797- }
3798- }
3799-
3800- return \@trimmed_cxns;
3801-}
3802-
3803-sub DESTROY {
3804- my ($self) = @_;
3805-
3806- PTDEBUG && _d('Destroying cxn');
3807-
3808- if ( $self->{parent} ) {
3809- PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
3810- }
3811- elsif ( $self->{dbh}
3812- && blessed($self->{dbh})
3813- && $self->{dbh}->can("disconnect") )
3814- {
3815- PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
3816- $self->{dsn_name});
3817- $self->{dbh}->disconnect();
3818- }
3819-
3820- return;
3821-}
3822-
3823-sub _d {
3824- my ($package, undef, $line) = caller 0;
3825- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3826- map { defined $_ ? $_ : 'undef' }
3827- @_;
3828- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3829-}
3830-
3831-1;
3832-}
3833-# ###########################################################################
3834-# End Cxn package
3835-# ###########################################################################
3836-
3837-# ###########################################################################
3838-# Quoter package
3839-# This package is a copy without comments from the original. The original
3840-# with comments and its test file can be found in the Bazaar repository at,
3841-# lib/Quoter.pm
3842-# t/lib/Quoter.t
3843-# See https://launchpad.net/percona-toolkit for more information.
3844-# ###########################################################################
3845-{
3846-package Quoter;
3847-
3848-use strict;
3849-use warnings FATAL => 'all';
3850-use English qw(-no_match_vars);
3851-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3852-
3853-use Data::Dumper;
3854-$Data::Dumper::Indent = 1;
3855-$Data::Dumper::Sortkeys = 1;
3856-$Data::Dumper::Quotekeys = 0;
3857-
3858-sub new {
3859- my ( $class, %args ) = @_;
3860- return bless {}, $class;
3861-}
3862-
3863-sub quote {
3864- my ( $self, @vals ) = @_;
3865- foreach my $val ( @vals ) {
3866- $val =~ s/`/``/g;
3867- }
3868- return join('.', map { '`' . $_ . '`' } @vals);
3869-}
3870-
3871-sub quote_val {
3872- my ( $self, $val, %args ) = @_;
3873-
3874- return 'NULL' unless defined $val; # undef = NULL
3875- return "''" if $val eq ''; # blank string = ''
3876- return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data
3877- && !$args{is_char}; # unless is_char is true
3878-
3879- return $val if $args{is_float};
3880-
3881- $val =~ s/(['\\])/\\$1/g;
3882- return "'$val'";
3883-}
3884-
3885-sub split_unquote {
3886- my ( $self, $db_tbl, $default_db ) = @_;
3887- my ( $db, $tbl ) = split(/[.]/, $db_tbl);
3888- if ( !$tbl ) {
3889- $tbl = $db;
3890- $db = $default_db;
3891- }
3892- for ($db, $tbl) {
3893- next unless $_;
3894- s/\A`//;
3895- s/`\z//;
3896- s/``/`/g;
3897- }
3898-
3899- return ($db, $tbl);
3900-}
3901-
3902-sub literal_like {
3903- my ( $self, $like ) = @_;
3904- return unless $like;
3905- $like =~ s/([%_])/\\$1/g;
3906- return "'$like'";
3907-}
3908-
3909-sub join_quote {
3910- my ( $self, $default_db, $db_tbl ) = @_;
3911- return unless $db_tbl;
3912- my ($db, $tbl) = split(/[.]/, $db_tbl);
3913- if ( !$tbl ) {
3914- $tbl = $db;
3915- $db = $default_db;
3916- }
3917- $db = "`$db`" if $db && $db !~ m/^`/;
3918- $tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
3919- return $db ? "$db.$tbl" : $tbl;
3920-}
3921-
3922-sub serialize_list {
3923- my ( $self, @args ) = @_;
3924- PTDEBUG && _d('Serializing', Dumper(\@args));
3925- return unless @args;
3926-
3927- my @parts;
3928- foreach my $arg ( @args ) {
3929- if ( defined $arg ) {
3930- $arg =~ s/,/\\,/g; # escape commas
3931- $arg =~ s/\\N/\\\\N/g; # escape literal \N
3932- push @parts, $arg;
3933- }
3934- else {
3935- push @parts, '\N';
3936- }
3937- }
3938-
3939- my $string = join(',', @parts);
3940- PTDEBUG && _d('Serialized: <', $string, '>');
3941- return $string;
3942-}
3943-
3944-sub deserialize_list {
3945- my ( $self, $string ) = @_;
3946- PTDEBUG && _d('Deserializing <', $string, '>');
3947- die "Cannot deserialize an undefined string" unless defined $string;
3948-
3949- my @parts;
3950- foreach my $arg ( split(/(?<!\\),/, $string) ) {
3951- if ( $arg eq '\N' ) {
3952- $arg = undef;
3953- }
3954- else {
3955- $arg =~ s/\\,/,/g;
3956- $arg =~ s/\\\\N/\\N/g;
3957- }
3958- push @parts, $arg;
3959- }
3960-
3961- if ( !@parts ) {
3962- my $n_empty_strings = $string =~ tr/,//;
3963- $n_empty_strings++;
3964- PTDEBUG && _d($n_empty_strings, 'empty strings');
3965- map { push @parts, '' } 1..$n_empty_strings;
3966- }
3967- elsif ( $string =~ m/(?<!\\),$/ ) {
3968- PTDEBUG && _d('Last value is an empty string');
3969- push @parts, '';
3970- }
3971-
3972- PTDEBUG && _d('Deserialized', Dumper(\@parts));
3973- return @parts;
3974-}
3975-
3976-sub _d {
3977- my ($package, undef, $line) = caller 0;
3978- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3979- map { defined $_ ? $_ : 'undef' }
3980- @_;
3981- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3982-}
3983-
3984-1;
3985-}
3986-# ###########################################################################
3987-# End Quoter package
3988-# ###########################################################################
3989-
3990-# ###########################################################################
3991-# VersionParser package
3992-# This package is a copy without comments from the original. The original
3993-# with comments and its test file can be found in the Bazaar repository at,
3994-# lib/VersionParser.pm
3995-# t/lib/VersionParser.t
3996-# See https://launchpad.net/percona-toolkit for more information.
3997-# ###########################################################################
3998-{
3999-package VersionParser;
4000-
4001-use Lmo;
4002-use Scalar::Util qw(blessed);
4003-use English qw(-no_match_vars);
4004-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4005-
4006-use overload (
4007- '""' => "version",
4008- '<=>' => "cmp",
4009- 'cmp' => "cmp",
4010- fallback => 1,
4011-);
4012-
4013-use Carp ();
4014-
4015-has major => (
4016- is => 'ro',
4017- isa => 'Int',
4018- required => 1,
4019-);
4020-
4021-has [qw( minor revision )] => (
4022- is => 'ro',
4023- isa => 'Num',
4024-);
4025-
4026-has flavor => (
4027- is => 'ro',
4028- isa => 'Str',
4029- default => sub { 'Unknown' },
4030-);
4031-
4032-has innodb_version => (
4033- is => 'ro',
4034- isa => 'Str',
4035- default => sub { 'NO' },
4036-);
4037-
4038-sub series {
4039- my $self = shift;
4040- return $self->_join_version($self->major, $self->minor);
4041-}
4042-
4043-sub version {
4044- my $self = shift;
4045- return $self->_join_version($self->major, $self->minor, $self->revision);
4046-}
4047-
4048-sub is_in {
4049- my ($self, $target) = @_;
4050-
4051- return $self eq $target;
4052-}
4053-
4054-sub _join_version {
4055- my ($self, @parts) = @_;
4056-
4057- return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts;
4058-}
4059-sub _split_version {
4060- my ($self, $str) = @_;
4061- my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g;
4062- return @version_parts[0..2];
4063-}
4064-
4065-sub normalized_version {
4066- my ( $self ) = @_;
4067- my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major,
4068- $self->minor,
4069- $self->revision);
4070- PTDEBUG && _d($self->version, 'normalizes to', $result);
4071- return $result;
4072-}
4073-
4074-sub comment {
4075- my ( $self, $cmd ) = @_;
4076- my $v = $self->normalized_version();
4077-
4078- return "/*!$v $cmd */"
4079-}
4080-
4081-my @methods = qw(major minor revision);
4082-sub cmp {
4083- my ($left, $right) = @_;
4084- my $right_obj = (blessed($right) && $right->isa(ref($left)))
4085- ? $right
4086- : ref($left)->new($right);
4087-
4088- my $retval = 0;
4089- for my $m ( @methods ) {
4090- last unless defined($left->$m) && defined($right_obj->$m);
4091- $retval = $left->$m <=> $right_obj->$m;
4092- last if $retval;
4093- }
4094- return $retval;
4095-}
4096-
4097-sub BUILDARGS {
4098- my $self = shift;
4099-
4100- if ( @_ == 1 ) {
4101- my %args;
4102- if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) {
4103- PTDEBUG && _d("VersionParser got a dbh, trying to get the version");
4104- my $dbh = $_[0];
4105- local $dbh->{FetchHashKeyName} = 'NAME_lc';
4106- my $query = eval {
4107- $dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} })
4108- };
4109- if ( $query ) {
4110- $query = { map { $_->{variable_name} => $_->{value} } @$query };
4111- @args{@methods} = $self->_split_version($query->{version});
4112- $args{flavor} = delete $query->{version_comment}
4113- if $query->{version_comment};
4114- }
4115- elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) {
4116- @args{@methods} = $self->_split_version($query);
4117- }
4118- else {
4119- Carp::confess("Couldn't get the version from the dbh while "
4120- . "creating a VersionParser object: $@");
4121- }
4122- $args{innodb_version} = eval { $self->_innodb_version($dbh) };
4123- }
4124- elsif ( !ref($_[0]) ) {
4125- @args{@methods} = $self->_split_version($_[0]);
4126- }
4127-
4128- for my $method (@methods) {
4129- delete $args{$method} unless defined $args{$method};
4130- }
4131- @_ = %args if %args;
4132- }
4133-
4134- return $self->SUPER::BUILDARGS(@_);
4135-}
4136-
4137-sub _innodb_version {
4138- my ( $self, $dbh ) = @_;
4139- return unless $dbh;
4140- my $innodb_version = "NO";
4141-
4142- my ($innodb) =
4143- grep { $_->{engine} =~ m/InnoDB/i }
4144- map {
4145- my %hash;
4146- @hash{ map { lc $_ } keys %$_ } = values %$_;
4147- \%hash;
4148- }
4149- @{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
4150- if ( $innodb ) {
4151- PTDEBUG && _d("InnoDB support:", $innodb->{support});
4152- if ( $innodb->{support} =~ m/YES|DEFAULT/i ) {
4153- my $vars = $dbh->selectrow_hashref(
4154- "SHOW VARIABLES LIKE 'innodb_version'");
4155- $innodb_version = !$vars ? "BUILTIN"
4156- : ($vars->{Value} || $vars->{value});
4157- }
4158- else {
4159- $innodb_version = $innodb->{support}; # probably DISABLED or NO
4160- }
4161- }
4162-
4163- PTDEBUG && _d("InnoDB version:", $innodb_version);
4164- return $innodb_version;
4165-}
4166-
4167-sub _d {
4168- my ($package, undef, $line) = caller 0;
4169- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4170- map { defined $_ ? $_ : 'undef' }
4171- @_;
4172- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4173-}
4174-
4175-no Lmo;
4176-1;
4177-}
4178-# ###########################################################################
4179-# End VersionParser package
4180-# ###########################################################################
4181-
4182-# ###########################################################################
4183-# Daemon package
4184-# This package is a copy without comments from the original. The original
4185-# with comments and its test file can be found in the Bazaar repository at,
4186-# lib/Daemon.pm
4187-# t/lib/Daemon.t
4188-# See https://launchpad.net/percona-toolkit for more information.
4189-# ###########################################################################
4190-{
4191-package Daemon;
4192-
4193-use strict;
4194-use warnings FATAL => 'all';
4195-use English qw(-no_match_vars);
4196-
4197-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4198-
4199-use POSIX qw(setsid);
4200-use Fcntl qw(:DEFAULT);
4201-
4202-sub new {
4203- my ($class, %args) = @_;
4204- my $self = {
4205- log_file => $args{log_file},
4206- pid_file => $args{pid_file},
4207- daemonize => $args{daemonize},
4208- force_log_file => $args{force_log_file},
4209- parent_exit => $args{parent_exit},
4210- pid_file_owner => 0,
4211- };
4212- return bless $self, $class;
4213-}
4214-
4215-sub run {
4216- my ($self) = @_;
4217-
4218- my $daemonize = $self->{daemonize};
4219- my $pid_file = $self->{pid_file};
4220- my $log_file = $self->{log_file};
4221- my $force_log_file = $self->{force_log_file};
4222- my $parent_exit = $self->{parent_exit};
4223-
4224- PTDEBUG && _d('Starting daemon');
4225-
4226- if ( $pid_file ) {
4227- eval {
4228- $self->_make_pid_file(
4229- pid => $PID, # parent's pid
4230- pid_file => $pid_file,
4231- );
4232- };
4233- die "$EVAL_ERROR\n" if $EVAL_ERROR;
4234- if ( !$daemonize ) {
4235- $self->{pid_file_owner} = $PID; # parent's pid
4236- }
4237- }
4238-
4239- if ( $daemonize ) {
4240- defined (my $child_pid = fork()) or die "Cannot fork: $OS_ERROR";
4241- if ( $child_pid ) {
4242- PTDEBUG && _d('Forked child', $child_pid);
4243- $parent_exit->($child_pid) if $parent_exit;
4244- exit 0;
4245- }
4246-
4247- POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
4248- chdir '/' or die "Cannot chdir to /: $OS_ERROR";
4249-
4250- if ( $pid_file ) {
4251- $self->_update_pid_file(
4252- pid => $PID, # child's pid
4253- pid_file => $pid_file,
4254- );
4255- $self->{pid_file_owner} = $PID;
4256- }
4257- }
4258-
4259- if ( $daemonize || $force_log_file ) {
4260- PTDEBUG && _d('Redirecting STDIN to /dev/null');
4261- close STDIN;
4262- open STDIN, '/dev/null'
4263- or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
4264- if ( $log_file ) {
4265- PTDEBUG && _d('Redirecting STDOUT and STDERR to', $log_file);
4266- close STDOUT;
4267- open STDOUT, '>>', $log_file
4268- or die "Cannot open log file $log_file: $OS_ERROR";
4269-
4270- close STDERR;
4271- open STDERR, ">&STDOUT"
4272- or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
4273- }
4274- else {
4275- if ( -t STDOUT ) {
4276- PTDEBUG && _d('No log file and STDOUT is a terminal;',
4277- 'redirecting to /dev/null');
4278- close STDOUT;
4279- open STDOUT, '>', '/dev/null'
4280- or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
4281- }
4282- if ( -t STDERR ) {
4283- PTDEBUG && _d('No log file and STDERR is a terminal;',
4284- 'redirecting to /dev/null');
4285- close STDERR;
4286- open STDERR, '>', '/dev/null'
4287- or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
4288- }
4289- }
4290-
4291- $OUTPUT_AUTOFLUSH = 1;
4292- }
4293-
4294- PTDEBUG && _d('Daemon running');
4295- return;
4296-}
4297-
4298-sub _make_pid_file {
4299- my ($self, %args) = @_;
4300- my @required_args = qw(pid pid_file);
4301- foreach my $arg ( @required_args ) {
4302- die "I need a $arg argument" unless $args{$arg};
4303- };
4304- my $pid = $args{pid};
4305- my $pid_file = $args{pid_file};
4306-
4307- eval {
4308- sysopen(PID_FH, $pid_file, O_RDWR|O_CREAT|O_EXCL) or die $OS_ERROR;
4309- print PID_FH $PID, "\n";
4310- close PID_FH;
4311- };
4312- if ( my $e = $EVAL_ERROR ) {
4313- if ( $e =~ m/file exists/i ) {
4314- my $old_pid = $self->_check_pid_file(
4315- pid_file => $pid_file,
4316- pid => $PID,
4317- );
4318- if ( $old_pid ) {
4319- warn "Overwriting PID file $pid_file because PID $old_pid "
4320- . "is not running.\n";
4321- }
4322- $self->_update_pid_file(
4323- pid => $PID,
4324- pid_file => $pid_file
4325- );
4326- }
4327- else {
4328- die "Error creating PID file $pid_file: $e\n";
4329- }
4330- }
4331-
4332- return;
4333-}
4334-
4335-sub _check_pid_file {
4336- my ($self, %args) = @_;
4337- my @required_args = qw(pid_file pid);
4338- foreach my $arg ( @required_args ) {
4339- die "I need a $arg argument" unless $args{$arg};
4340- };
4341- my $pid_file = $args{pid_file};
4342- my $pid = $args{pid};
4343-
4344- PTDEBUG && _d('Checking if PID in', $pid_file, 'is running');
4345-
4346- if ( ! -f $pid_file ) {
4347- PTDEBUG && _d('PID file', $pid_file, 'does not exist');
4348- return;
4349- }
4350-
4351- open my $fh, '<', $pid_file
4352- or die "Error opening $pid_file: $OS_ERROR";
4353- my $existing_pid = do { local $/; <$fh> };
4354- chomp($existing_pid) if $existing_pid;
4355- close $fh
4356- or die "Error closing $pid_file: $OS_ERROR";
4357-
4358- if ( $existing_pid ) {
4359- if ( $existing_pid == $pid ) {
4360- warn "The current PID $pid already holds the PID file $pid_file\n";
4361- return;
4362- }
4363- else {
4364- PTDEBUG && _d('Checking if PID', $existing_pid, 'is running');
4365- my $pid_is_alive = kill 0, $existing_pid;
4366- if ( $pid_is_alive ) {
4367- die "PID file $pid_file exists and PID $existing_pid is running\n";
4368- }
4369- }
4370- }
4371- else {
4372- die "PID file $pid_file exists but it is empty. Remove the file "
4373- . "if the process is no longer running.\n";
4374- }
4375-
4376- return $existing_pid;
4377-}
4378-
4379-sub _update_pid_file {
4380- my ($self, %args) = @_;
4381- my @required_args = qw(pid pid_file);
4382- foreach my $arg ( @required_args ) {
4383- die "I need a $arg argument" unless $args{$arg};
4384- };
4385- my $pid = $args{pid};
4386- my $pid_file = $args{pid_file};
4387-
4388- open my $fh, '>', $pid_file
4389- or die "Cannot open $pid_file: $OS_ERROR";
4390- print { $fh } $pid, "\n"
4391- or die "Cannot print to $pid_file: $OS_ERROR";
4392- close $fh
4393- or warn "Cannot close $pid_file: $OS_ERROR";
4394-
4395- return;
4396-}
4397-
4398-sub remove_pid_file {
4399- my ($self, $pid_file) = @_;
4400- $pid_file ||= $self->{pid_file};
4401- if ( $pid_file && -f $pid_file ) {
4402- unlink $self->{pid_file}
4403- or warn "Cannot remove PID file $pid_file: $OS_ERROR";
4404- PTDEBUG && _d('Removed PID file');
4405- }
4406- else {
4407- PTDEBUG && _d('No PID to remove');
4408- }
4409- return;
4410-}
4411-
4412-sub DESTROY {
4413- my ($self) = @_;
4414-
4415- if ( $self->{pid_file_owner} == $PID ) {
4416- $self->remove_pid_file();
4417- }
4418-
4419- return;
4420-}
4421-
4422-sub _d {
4423- my ($package, undef, $line) = caller 0;
4424- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4425- map { defined $_ ? $_ : 'undef' }
4426- @_;
4427- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4428-}
4429-
4430-1;
4431-}
4432-# ###########################################################################
4433-# End Daemon package
4434-# ###########################################################################
4435-
4436-# ###########################################################################
4437-# Transformers package
4438-# This package is a copy without comments from the original. The original
4439-# with comments and its test file can be found in the Bazaar repository at,
4440-# lib/Transformers.pm
4441-# t/lib/Transformers.t
4442-# See https://launchpad.net/percona-toolkit for more information.
4443-# ###########################################################################
4444-{
4445-package Transformers;
4446-
4447-use strict;
4448-use warnings FATAL => 'all';
4449-use English qw(-no_match_vars);
4450-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4451-
4452-use Time::Local qw(timegm timelocal);
4453-use Digest::MD5 qw(md5_hex);
4454-use B qw();
4455-
4456-BEGIN {
4457- require Exporter;
4458- our @ISA = qw(Exporter);
4459- our %EXPORT_TAGS = ();
4460- our @EXPORT = ();
4461- our @EXPORT_OK = qw(
4462- micro_t
4463- percentage_of
4464- secs_to_time
4465- time_to_secs
4466- shorten
4467- ts
4468- parse_timestamp
4469- unix_timestamp
4470- any_unix_timestamp
4471- make_checksum
4472- crc32
4473- encode_json
4474- );
4475-}
4476-
4477-our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
4478-our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
4479-our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
4480-
4481-sub micro_t {
4482- my ( $t, %args ) = @_;
4483- my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
4484- my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
4485- my $f;
4486-
4487- $t = 0 if $t < 0;
4488-
4489- $t = sprintf('%.17f', $t) if $t =~ /e/;
4490-
4491- $t =~ s/\.(\d{1,6})\d*/\.$1/;
4492-
4493- if ($t > 0 && $t <= 0.000999) {
4494- $f = ($t * 1000000) . 'us';
4495- }
4496- elsif ($t >= 0.001000 && $t <= 0.999999) {
4497- $f = sprintf("%.${p_ms}f", $t * 1000);
4498- $f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
4499- }
4500- elsif ($t >= 1) {
4501- $f = sprintf("%.${p_s}f", $t);
4502- $f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
4503- }
4504- else {
4505- $f = 0; # $t should = 0 at this point
4506- }
4507-
4508- return $f;
4509-}
4510-
4511-sub percentage_of {
4512- my ( $is, $of, %args ) = @_;
4513- my $p = $args{p} || 0; # float precision
4514- my $fmt = $p ? "%.${p}f" : "%d";
4515- return sprintf $fmt, ($is * 100) / ($of ||= 1);
4516-}
4517-
4518-sub secs_to_time {
4519- my ( $secs, $fmt ) = @_;
4520- $secs ||= 0;
4521- return '00:00' unless $secs;
4522-
4523- $fmt ||= $secs >= 86_400 ? 'd'
4524- : $secs >= 3_600 ? 'h'
4525- : 'm';
4526-
4527- return
4528- $fmt eq 'd' ? sprintf(
4529- "%d+%02d:%02d:%02d",
4530- int($secs / 86_400),
4531- int(($secs % 86_400) / 3_600),
4532- int(($secs % 3_600) / 60),
4533- $secs % 60)
4534- : $fmt eq 'h' ? sprintf(
4535- "%02d:%02d:%02d",
4536- int(($secs % 86_400) / 3_600),
4537- int(($secs % 3_600) / 60),
4538- $secs % 60)
4539- : sprintf(
4540- "%02d:%02d",
4541- int(($secs % 3_600) / 60),
4542- $secs % 60);
4543-}
4544-
4545-sub time_to_secs {
4546- my ( $val, $default_suffix ) = @_;
4547- die "I need a val argument" unless defined $val;
4548- my $t = 0;
4549- my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
4550- $suffix = $suffix || $default_suffix || 's';
4551- if ( $suffix =~ m/[smhd]/ ) {
4552- $t = $suffix eq 's' ? $num * 1 # Seconds
4553- : $suffix eq 'm' ? $num * 60 # Minutes
4554- : $suffix eq 'h' ? $num * 3600 # Hours
4555- : $num * 86400; # Days
4556-
4557- $t *= -1 if $prefix && $prefix eq '-';
4558- }
4559- else {
4560- die "Invalid suffix for $val: $suffix";
4561- }
4562- return $t;
4563-}
4564-
4565-sub shorten {
4566- my ( $num, %args ) = @_;
4567- my $p = defined $args{p} ? $args{p} : 2; # float precision
4568- my $d = defined $args{d} ? $args{d} : 1_024; # divisor
4569- my $n = 0;
4570- my @units = ('', qw(k M G T P E Z Y));
4571- while ( $num >= $d && $n < @units - 1 ) {
4572- $num /= $d;
4573- ++$n;
4574- }
4575- return sprintf(
4576- $num =~ m/\./ || $n
4577- ? "%.${p}f%s"
4578- : '%d',
4579- $num, $units[$n]);
4580-}
4581-
4582-sub ts {
4583- my ( $time, $gmt ) = @_;
4584- my ( $sec, $min, $hour, $mday, $mon, $year )
4585- = $gmt ? gmtime($time) : localtime($time);
4586- $mon += 1;
4587- $year += 1900;
4588- my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
4589- $year, $mon, $mday, $hour, $min, $sec);
4590- if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
4591- $us = sprintf("%.6f", $us);
4592- $us =~ s/^0\././;
4593- $val .= $us;
4594- }
4595- return $val;
4596-}
4597-
4598-sub parse_timestamp {
4599- my ( $val ) = @_;
4600- if ( my($y, $m, $d, $h, $i, $s, $f)
4601- = $val =~ m/^$mysql_ts$/ )
4602- {
4603- return sprintf "%d-%02d-%02d %02d:%02d:"
4604- . (defined $f ? '%09.6f' : '%02d'),
4605- $y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
4606- }
4607- elsif ( $val =~ m/^$proper_ts$/ ) {
4608- return $val;
4609- }
4610- return $val;
4611-}
4612-
4613-sub unix_timestamp {
4614- my ( $val, $gmt ) = @_;
4615- if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
4616- $val = $gmt
4617- ? timegm($s, $i, $h, $d, $m - 1, $y)
4618- : timelocal($s, $i, $h, $d, $m - 1, $y);
4619- if ( defined $us ) {
4620- $us = sprintf('%.6f', $us);
4621- $us =~ s/^0\././;
4622- $val .= $us;
4623- }
4624- }
4625- return $val;
4626-}
4627-
4628-sub any_unix_timestamp {
4629- my ( $val, $callback ) = @_;
4630-
4631- if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
4632- $n = $suffix eq 's' ? $n # Seconds
4633- : $suffix eq 'm' ? $n * 60 # Minutes
4634- : $suffix eq 'h' ? $n * 3600 # Hours
4635- : $suffix eq 'd' ? $n * 86400 # Days
4636- : $n; # default: Seconds
4637- PTDEBUG && _d('ts is now - N[shmd]:', $n);
4638- return time - $n;
4639- }
4640- elsif ( $val =~ m/^\d{9,}/ ) {
4641- PTDEBUG && _d('ts is already a unix timestamp');
4642- return $val;
4643- }
4644- elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
4645- PTDEBUG && _d('ts is MySQL slow log timestamp');
4646- $val .= ' 00:00:00' unless $hms;
4647- return unix_timestamp(parse_timestamp($val));
4648- }
4649- elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
4650- PTDEBUG && _d('ts is properly formatted timestamp');
4651- $val .= ' 00:00:00' unless $hms;
4652- return unix_timestamp($val);
4653- }
4654- else {
4655- PTDEBUG && _d('ts is MySQL expression');
4656- return $callback->($val) if $callback && ref $callback eq 'CODE';
4657- }
4658-
4659- PTDEBUG && _d('Unknown ts type:', $val);
4660- return;
4661-}
4662-
4663-sub make_checksum {
4664- my ( $val ) = @_;
4665- my $checksum = uc substr(md5_hex($val), -16);
4666- PTDEBUG && _d($checksum, 'checksum for', $val);
4667- return $checksum;
4668-}
4669-
4670-sub crc32 {
4671- my ( $string ) = @_;
4672- return unless $string;
4673- my $poly = 0xEDB88320;
4674- my $crc = 0xFFFFFFFF;
4675- foreach my $char ( split(//, $string) ) {
4676- my $comp = ($crc ^ ord($char)) & 0xFF;
4677- for ( 1 .. 8 ) {
4678- $comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
4679- }
4680- $crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
4681- }
4682- return $crc ^ 0xFFFFFFFF;
4683-}
4684-
4685-my $got_json = eval { require JSON };
4686-sub encode_json {
4687- return JSON::encode_json(@_) if $got_json;
4688- my ( $data ) = @_;
4689- return (object_to_json($data) || '');
4690-}
4691-
4692-
4693-sub object_to_json {
4694- my ($obj) = @_;
4695- my $type = ref($obj);
4696-
4697- if($type eq 'HASH'){
4698- return hash_to_json($obj);
4699- }
4700- elsif($type eq 'ARRAY'){
4701- return array_to_json($obj);
4702- }
4703- else {
4704- return value_to_json($obj);
4705- }
4706-}
4707-
4708-sub hash_to_json {
4709- my ($obj) = @_;
4710- my @res;
4711- for my $k ( sort { $a cmp $b } keys %$obj ) {
4712- push @res, string_to_json( $k )
4713- . ":"
4714- . ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) );
4715- }
4716- return '{' . ( @res ? join( ",", @res ) : '' ) . '}';
4717-}
4718-
4719-sub array_to_json {
4720- my ($obj) = @_;
4721- my @res;
4722-
4723- for my $v (@$obj) {
4724- push @res, object_to_json($v) || value_to_json($v);
4725- }
4726-
4727- return '[' . ( @res ? join( ",", @res ) : '' ) . ']';
4728-}
4729-
4730-sub value_to_json {
4731- my ($value) = @_;
4732-
4733- return 'null' if(!defined $value);
4734-
4735- my $b_obj = B::svref_2object(\$value); # for round trip problem
4736- my $flags = $b_obj->FLAGS;
4737- return $value # as is
4738- if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
4739-
4740- my $type = ref($value);
4741-
4742- if( !$type ) {
4743- return string_to_json($value);
4744- }
4745- else {
4746- return 'null';
4747- }
4748-
4749-}
4750-
4751-my %esc = (
4752- "\n" => '\n',
4753- "\r" => '\r',
4754- "\t" => '\t',
4755- "\f" => '\f',
4756- "\b" => '\b',
4757- "\"" => '\"',
4758- "\\" => '\\\\',
4759- "\'" => '\\\'',
4760-);
4761-
4762-sub string_to_json {
4763- my ($arg) = @_;
4764-
4765- $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
4766- $arg =~ s/\//\\\//g;
4767- $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
4768-
4769- utf8::upgrade($arg);
4770- utf8::encode($arg);
4771-
4772- return '"' . $arg . '"';
4773-}
4774-
4775-sub _d {
4776- my ($package, undef, $line) = caller 0;
4777- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4778- map { defined $_ ? $_ : 'undef' }
4779- @_;
4780- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4781-}
4782-
4783-1;
4784-}
4785-# ###########################################################################
4786-# End Transformers package
4787-# ###########################################################################
4788-
4789-# ###########################################################################
4790-# Safeguards package
4791-# This package is a copy without comments from the original. The original
4792-# with comments and its test file can be found in the Bazaar repository at,
4793-# lib/Safeguards.pm
4794-# t/lib/Safeguards.t
4795-# See https://launchpad.net/percona-toolkit for more information.
4796-# ###########################################################################
4797-{
4798-package Safeguards;
4799-
4800-use strict;
4801-use warnings FATAL => 'all';
4802-use English qw(-no_match_vars);
4803-
4804-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4805-
4806-sub new {
4807- my ($class, %args) = @_;
4808- my $self = {
4809- disk_bytes_free => $args{disk_bytes_free} || 104857600, # 100 MiB
4810- disk_pct_free => $args{disk_pct_free} || 5,
4811- };
4812- return bless $self, $class;
4813-}
4814-
4815-sub get_disk_space {
4816- my ($self, %args) = @_;
4817- my $filesystem = $args{filesystem} || $ENV{PWD};
4818-
4819- my $disk_space = `df -P -k "$filesystem"`;
4820- chop($disk_space) if $disk_space;
4821- PTDEBUG && _d('Disk space on', $filesystem, $disk_space);
4822-
4823- return $disk_space;
4824-}
4825-
4826-sub check_disk_space() {
4827- my ($self, %args) = @_;
4828- my $disk_space = $args{disk_space};
4829- PTDEBUG && _d("Checking disk space:\n", $disk_space);
4830-
4831- my ($partition) = $disk_space =~ m/^\s*(\/.+)/m;
4832- PTDEBUG && _d('Partition:', $partition);
4833- die "Failed to parse partition from disk space:\n$disk_space"
4834- unless $partition;
4835-
4836- my (undef, undef, $bytes_used, $bytes_free, $pct_used, undef)
4837- = $partition =~ m/(\S+)/g;
4838- PTDEBUG && _d('Bytes used:', $bytes_used, 'free:', $bytes_free,
4839- 'Percentage used:', $pct_used);
4840-
4841- $bytes_used = ($bytes_used || 0) * 1024;
4842- $bytes_free = ($bytes_free || 0) * 1024;
4843-
4844- $pct_used =~ s/%//;
4845- my $pct_free = 100 - ($pct_used || 0);
4846-
4847- return $bytes_free >= $self->{disk_bytes_free}
4848- && $pct_free >= $self->{disk_pct_free};
4849-}
4850-
4851-sub _d {
4852- my ($package, undef, $line) = caller 0;
4853- @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4854- map { defined $_ ? $_ : 'undef' }
4855- @_;
4856- print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4857-}
4858-
4859-1;
4860-}
4861-# ###########################################################################
4862-# End Safeguards package
4863-# ###########################################################################
4864-
4865-# ###########################################################################
4866-# Percona::Agent::Logger package
4867-# This package is a copy without comments from the original. The original
4868-# with comments and its test file can be found in the Bazaar repository at,
4869-# lib/Percona/Agent/Logger.pm
4870-# t/lib/Percona/Agent/Logger.t
4871-# See https://launchpad.net/percona-toolkit for more information.
4872-# ###########################################################################
4873-{
4874-package Percona::Agent::Logger;
4875-
4876-use strict;
4877-use warnings FATAL => 'all';
4878-use English qw(-no_match_vars);
4879-
4880-use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4881-
4882-use POSIX qw(SIGALRM);
4883-
4884-use Lmo;
4885-use Transformers;
4886-use Percona::WebAPI::Resource::LogEntry;
4887-
4888-Transformers->import(qw(ts));
4889-
4890-has 'exit_status' => (
4891- is => 'rw',
4892- isa => 'ScalarRef',
4893- required => 1,
4894-);
4895-
4896-has 'pid' => (
4897- is => 'ro',
4898- isa => 'Int',
4899- required => 1,
4900-);
4901-
4902-has 'service' => (
4903- is => 'rw',
4904- isa => 'Maybe[Str]',
4905- required => 0,
4906- default => sub { return; },
4907-);
4908-
4909-has 'data_ts' => (
4910- is => 'rw',
4911- isa => 'Maybe[Int]',
4912- required => 0,
4913- default => sub { return; },
4914-);
4915-
4916-has 'online_logging' => (
4917- is => 'ro',
4918- isa => 'Bool',
4919- required => 0,
4920- default => sub { return 1 },
4921-);
4922-
4923-has 'online_logging_enabled' => (
4924- is => 'rw',
4925- isa => 'Bool',
4926- required => 0,
4927- default => sub { return 0 },
4928-);
4929-
4930-has 'quiet' => (
4931- is => 'rw',
4932- isa => 'Int',
4933- required => 0,
4934- default => sub { return 0 },
4935-);
4936-
4937-has '_buffer' => (
4938- is => 'rw',
4939- isa => 'ArrayRef',
4940- required => 0,
4941- default => sub { return []; },
4942-);
4943-
4944-has '_pipe_write' => (
4945- is => 'rw',
4946- isa => 'Maybe[FileHandle]',
4947- required => 0,
4948-);
4949-
4950-sub read_stdin {
4951- my ( $t ) = @_;
4952-
4953- POSIX::sigaction(
4954- SIGALRM,
4955- POSIX::SigAction->new(sub { die 'read timeout'; }),
4956- ) or die "Error setting SIGALRM handler: $OS_ERROR";
4957-
4958- my $timeout = 0;
4959- my @lines;
4960- eval {
4961- alarm $t;
4962- while(defined(my $line = <STDIN>)) {
4963- push @lines, $line;
4964- }
4965- alarm 0;
4966- };
4967- if ( $EVAL_ERROR ) {
4968- PTDEBUG && _d('Read error:', $EVAL_ERROR);
4969- die $EVAL_ERROR unless $EVAL_ERROR =~ m/read timeout/;
4970- $timeout = 1;
4971- }
4972- return unless scalar @lines || $timeout;
4973- return \@lines;
4974-}
4975-
4976-sub start_online_logging {
4977- my ($self, %args) = @_;
4978- my $client = $args{client};
4979- my $log_link = $args{log_link};
4980- my $read_timeout = $args{read_timeout} || 3;
4981-
4982- return unless $self->online_logging;
4983-
4984- my $pid = open(my $pipe_write, "|-");
4985-
4986- if ($pid) {
4987- select $pipe_write;
4988- $OUTPUT_AUTOFLUSH = 1;
4989- $self->_pipe_write($pipe_write);
4990- $self->online_logging_enabled(1);
4991- }
4992- else {
4993- my @log_entries;
4994- my $n_errors = 0;
4995- my $oktorun = 1;
4996- QUEUE:
4997- while ($oktorun) {
4998- my $lines = read_stdin($read_timeout);
4999- last QUEUE unless $lines;
5000- LINE:
The diff has been truncated for viewing.

Subscribers

People subscribed via source and target branches

to all changes: