system: Linux mars.sprixweb.com 3.10.0-1160.119.1.el7.x86_64 #1 SMP Tue Jun 4 14:43:51 UTC 2024 x86_64
| Direktori : /bin/ |
|
|
| Current File : //bin/pt-config-diff |
#!/usr/bin/env perl
# This program is part of Percona Toolkit: http://www.percona.com/software/
# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
# notices and disclaimers.
use strict;
use warnings FATAL => 'all';
# This tool is "fat-packed": most of its dependent modules are embedded
# in this file. Setting %INC to this file for each module makes Perl aware
# of this so it will not try to load the module from @INC. See the tool's
# documentation for a full list of dependencies.
BEGIN {
$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
Percona::Toolkit
Lmo::Utils
Lmo::Meta
Lmo::Object
Lmo::Types
Lmo
OptionParser
DSNParser
Cxn
Daemon
TextResultSetParser
MySQLConfig
MySQLConfigComparer
ReportFormatter
HTTP::Micro
VersionCheck
));
}
# ###########################################################################
# Percona::Toolkit package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Percona/Toolkit.pm
# t/lib/Percona/Toolkit.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Percona::Toolkit;
our $VERSION = '2.2.15';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Carp qw(carp cluck);
use Data::Dumper qw();
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
have_required_args
Dumper
_d
);
sub have_required_args {
my ($args, @required_args) = @_;
my $have_required_args = 1;
foreach my $arg ( @required_args ) {
if ( !defined $args->{$arg} ) {
$have_required_args = 0;
carp "Argument $arg is not defined";
}
}
cluck unless $have_required_args; # print backtrace
return $have_required_args;
}
sub Dumper {
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
Data::Dumper::Dumper(@_);
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Percona::Toolkit package
# ###########################################################################
# ###########################################################################
# Lmo::Utils package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Utils.pm
# t/lib/Lmo/Utils.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Utils;
use strict;
use warnings qw( FATAL all );
require Exporter;
our (@ISA, @EXPORT, @EXPORT_OK);
BEGIN {
@ISA = qw(Exporter);
@EXPORT = @EXPORT_OK = qw(
_install_coderef
_unimport_coderefs
_glob_for
_stash_for
);
}
{
no strict 'refs';
sub _glob_for {
return \*{shift()}
}
sub _stash_for {
return \%{ shift() . "::" };
}
}
sub _install_coderef {
my ($to, $code) = @_;
return *{ _glob_for $to } = $code;
}
sub _unimport_coderefs {
my ($target, @names) = @_;
return unless @names;
my $stash = _stash_for($target);
foreach my $name (@names) {
if ($stash->{$name} and defined(&{$stash->{$name}})) {
delete $stash->{$name};
}
}
}
1;
}
# ###########################################################################
# End Lmo::Utils package
# ###########################################################################
# ###########################################################################
# Lmo::Meta package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Meta.pm
# t/lib/Lmo/Meta.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Meta;
use strict;
use warnings qw( FATAL all );
my %metadata_for;
sub new {
my $class = shift;
return bless { @_ }, $class
}
sub metadata_for {
my $self = shift;
my ($class) = @_;
return $metadata_for{$class} ||= {};
}
sub class { shift->{class} }
sub attributes {
my $self = shift;
return keys %{$self->metadata_for($self->class)}
}
sub attributes_for_new {
my $self = shift;
my @attributes;
my $class_metadata = $self->metadata_for($self->class);
while ( my ($attr, $meta) = each %$class_metadata ) {
if ( exists $meta->{init_arg} ) {
push @attributes, $meta->{init_arg}
if defined $meta->{init_arg};
}
else {
push @attributes, $attr;
}
}
return @attributes;
}
1;
}
# ###########################################################################
# End Lmo::Meta package
# ###########################################################################
# ###########################################################################
# Lmo::Object package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Object.pm
# t/lib/Lmo/Object.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Object;
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(blessed);
use Lmo::Meta;
use Lmo::Utils qw(_glob_for);
sub new {
my $class = shift;
my $args = $class->BUILDARGS(@_);
my $class_metadata = Lmo::Meta->metadata_for($class);
my @args_to_delete;
while ( my ($attr, $meta) = each %$class_metadata ) {
next unless exists $meta->{init_arg};
my $init_arg = $meta->{init_arg};
if ( defined $init_arg ) {
$args->{$attr} = delete $args->{$init_arg};
}
else {
push @args_to_delete, $attr;
}
}
delete $args->{$_} for @args_to_delete;
for my $attribute ( keys %$args ) {
if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
$args->{$attribute} = $coerce->($args->{$attribute});
}
if ( my $isa_check = $class_metadata->{$attribute}{isa} ) {
my ($check_name, $check_sub) = @$isa_check;
$check_sub->($args->{$attribute});
}
}
while ( my ($attribute, $meta) = each %$class_metadata ) {
next unless $meta->{required};
Carp::confess("Attribute ($attribute) is required for $class")
if ! exists $args->{$attribute}
}
my $self = bless $args, $class;
my @build_subs;
my $linearized_isa = mro::get_linear_isa($class);
for my $isa_class ( @$linearized_isa ) {
unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE};
}
my @args = %$args;
for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
$sub->( $self, @args);
}
return $self;
}
sub BUILDARGS {
shift; # No need for the classname
if ( @_ == 1 && ref($_[0]) ) {
Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]")
unless ref($_[0]) eq ref({});
return {%{$_[0]}} # We want a new reference, always
}
else {
return { @_ };
}
}
sub meta {
my $class = shift;
$class = Scalar::Util::blessed($class) || $class;
return Lmo::Meta->new(class => $class);
}
1;
}
# ###########################################################################
# End Lmo::Object package
# ###########################################################################
# ###########################################################################
# Lmo::Types package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Types.pm
# t/lib/Lmo/Types.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Types;
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(looks_like_number blessed);
our %TYPES = (
Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) },
Num => sub { defined $_[0] && looks_like_number($_[0]) },
Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) },
Str => sub { defined $_[0] },
Object => sub { defined $_[0] && blessed($_[0]) },
FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened },
map {
my $type = /R/ ? $_ : uc $_;
$_ . "Ref" => sub { ref $_[0] eq $type }
} qw(Array Code Hash Regexp Glob Scalar)
);
sub check_type_constaints {
my ($attribute, $type_check, $check_name, $val) = @_;
( ref($type_check) eq 'CODE'
? $type_check->($val)
: (ref $val eq $type_check
|| ($val && $val eq $type_check)
|| (exists $TYPES{$type_check} && $TYPES{$type_check}->($val)))
)
|| Carp::confess(
qq<Attribute ($attribute) does not pass the type constraint because: >
. qq<Validation failed for '$check_name' with value >
. (defined $val ? Lmo::Dumper($val) : 'undef') )
}
sub _nested_constraints {
my ($attribute, $aggregate_type, $type) = @_;
my $inner_types;
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$inner_types = _nested_constraints($1, $2);
}
else {
$inner_types = $TYPES{$type};
}
if ( $aggregate_type eq 'ArrayRef' ) {
return sub {
my ($val) = @_;
return unless ref($val) eq ref([]);
if ($inner_types) {
for my $value ( @{$val} ) {
return unless $inner_types->($value)
}
}
else {
for my $value ( @{$val} ) {
return unless $value && ($value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type)));
}
}
return 1;
};
}
elsif ( $aggregate_type eq 'Maybe' ) {
return sub {
my ($value) = @_;
return 1 if ! defined($value);
if ($inner_types) {
return unless $inner_types->($value)
}
else {
return unless $value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type));
}
return 1;
}
}
else {
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
}
}
1;
}
# ###########################################################################
# End Lmo::Types package
# ###########################################################################
# ###########################################################################
# Lmo package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo.pm
# t/lib/Lmo.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
BEGIN {
$INC{"Lmo.pm"} = __FILE__;
package Lmo;
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(looks_like_number blessed);
use Lmo::Meta;
use Lmo::Object;
use Lmo::Types;
use Lmo::Utils;
my %export_for;
sub import {
warnings->import(qw(FATAL all));
strict->import();
my $caller = scalar caller(); # Caller's package
my %exports = (
extends => \&extends,
has => \&has,
with => \&with,
override => \&override,
confess => \&Carp::confess,
);
$export_for{$caller} = \%exports;
for my $keyword ( keys %exports ) {
_install_coderef "${caller}::$keyword" => $exports{$keyword};
}
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
@_ = "Lmo::Object";
goto *{ _glob_for "${caller}::extends" }{CODE};
}
}
sub extends {
my $caller = scalar caller();
for my $class ( @_ ) {
_load_module($class);
}
_set_package_isa($caller, @_);
_set_inherited_metadata($caller);
}
sub _load_module {
my ($class) = @_;
(my $file = $class) =~ s{::|'}{/}g;
$file .= '.pm';
{ local $@; eval { require "$file" } } # or warn $@;
return;
}
sub with {
my $package = scalar caller();
require Role::Tiny;
for my $role ( @_ ) {
_load_module($role);
_role_attribute_metadata($package, $role);
}
Role::Tiny->apply_roles_to_package($package, @_);
}
sub _role_attribute_metadata {
my ($package, $role) = @_;
my $package_meta = Lmo::Meta->metadata_for($package);
my $role_meta = Lmo::Meta->metadata_for($role);
%$package_meta = (%$role_meta, %$package_meta);
}
sub has {
my $names = shift;
my $caller = scalar caller();
my $class_metadata = Lmo::Meta->metadata_for($caller);
for my $attribute ( ref $names ? @$names : $names ) {
my %args = @_;
my $method = ($args{is} || '') eq 'ro'
? sub {
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
if $#_;
return $_[0]{$attribute};
}
: sub {
return $#_
? $_[0]{$attribute} = $_[1]
: $_[0]{$attribute};
};
$class_metadata->{$attribute} = ();
if ( my $type_check = $args{isa} ) {
my $check_name = $type_check;
if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
}
my $check_sub = sub {
my ($new_val) = @_;
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
};
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
my $orig_method = $method;
$method = sub {
$check_sub->($_[1]) if $#_;
goto &$orig_method;
};
}
if ( my $builder = $args{builder} ) {
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$builder
: goto &$original_method
};
}
if ( my $code = $args{default} ) {
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
unless ref($code) eq 'CODE';
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$code
: goto &$original_method
};
}
if ( my $role = $args{does} ) {
my $original_method = $method;
$method = sub {
if ( $#_ ) {
Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
}
goto &$original_method
};
}
if ( my $coercion = $args{coerce} ) {
$class_metadata->{$attribute}{coerce} = $coercion;
my $original_method = $method;
$method = sub {
if ( $#_ ) {
return $original_method->($_[0], $coercion->($_[1]))
}
goto &$original_method;
}
}
_install_coderef "${caller}::$attribute" => $method;
if ( $args{required} ) {
$class_metadata->{$attribute}{required} = 1;
}
if ($args{clearer}) {
_install_coderef "${caller}::$args{clearer}"
=> sub { delete shift->{$attribute} }
}
if ($args{predicate}) {
_install_coderef "${caller}::$args{predicate}"
=> sub { exists shift->{$attribute} }
}
if ($args{handles}) {
_has_handles($caller, $attribute, \%args);
}
if (exists $args{init_arg}) {
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
}
}
}
sub _has_handles {
my ($caller, $attribute, $args) = @_;
my $handles = $args->{handles};
my $ref = ref $handles;
my $kv;
if ( $ref eq ref [] ) {
$kv = { map { $_,$_ } @{$handles} };
}
elsif ( $ref eq ref {} ) {
$kv = $handles;
}
elsif ( $ref eq ref qr// ) {
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
unless $args->{isa};
my $target_class = $args->{isa};
$kv = {
map { $_, $_ }
grep { $_ =~ $handles }
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
grep { !$export_for{$target_class}->{$_} }
keys %{ _stash_for $target_class }
};
}
else {
Carp::confess("handles for $ref not yet implemented");
}
while ( my ($method, $target) = each %{$kv} ) {
my $name = _glob_for "${caller}::$method";
Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
if defined &$name;
my ($target, @curried_args) = ref($target) ? @$target : $target;
*$name = sub {
my $self = shift;
my $delegate_to = $self->$attribute();
my $error = "Cannot delegate $method to $target because the value of $attribute";
Carp::confess("$error is not defined") unless $delegate_to;
Carp::confess("$error is not an object (got '$delegate_to')")
unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
return $delegate_to->$target(@curried_args, @_);
}
}
}
sub _set_package_isa {
my ($package, @new_isa) = @_;
my $package_isa = \*{ _glob_for "${package}::ISA" };
@{*$package_isa} = @new_isa;
}
sub _set_inherited_metadata {
my $class = shift;
my $class_metadata = Lmo::Meta->metadata_for($class);
my $linearized_isa = mro::get_linear_isa($class);
my %new_metadata;
for my $isa_class (reverse @$linearized_isa) {
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
%new_metadata = (
%new_metadata,
%$isa_metadata,
);
}
%$class_metadata = %new_metadata;
}
sub unimport {
my $caller = scalar caller();
my $target = caller;
_unimport_coderefs($target, keys %{$export_for{$caller}});
}
sub Dumper {
require Data::Dumper;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Sortkeys = 0;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Terse = 1;
Data::Dumper::Dumper(@_)
}
BEGIN {
if ($] >= 5.010) {
{ local $@; require mro; }
}
else {
local $@;
eval {
require MRO::Compat;
} or do {
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
no strict 'refs';
my $classname = shift;
my @lin = ($classname);
my %stored;
foreach my $parent (@{"$classname\::ISA"}) {
my $plin = mro::get_linear_isa_dfs($parent);
foreach (@$plin) {
next if exists $stored{$_};
push(@lin, $_);
$stored{$_} = 1;
}
}
return \@lin;
};
}
}
}
sub override {
my ($methods, $code) = @_;
my $caller = scalar caller;
for my $method ( ref($methods) ? @$methods : $methods ) {
my $full_method = "${caller}::${method}";
*{_glob_for $full_method} = $code;
}
}
}
1;
}
# ###########################################################################
# End Lmo package
# ###########################################################################
# ###########################################################################
# OptionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/OptionParser.pm
# t/lib/OptionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package OptionParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use List::Util qw(max);
use Getopt::Long;
use Data::Dumper;
my $POD_link_re = '[LC]<"?([^">]+)"?>';
sub new {
my ( $class, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
$program_name ||= $PROGRAM_NAME;
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my %attributes = (
'type' => 1,
'short form' => 1,
'group' => 1,
'default' => 1,
'cumulative' => 1,
'negatable' => 1,
);
my $self = {
head1 => 'OPTIONS', # These args are used internally
skip_rules => 0, # to instantiate another Option-
item => '--(.*)', # Parser obj that parses the
attributes => \%attributes, # DSN OPTIONS section. Tools
parse_attributes => \&_parse_attribs, # don't tinker with these args.
%args,
strict => 1, # disabled by a special rule
program_name => $program_name,
opts => {},
got_opts => 0,
short_opts => {},
defaults => {},
groups => {},
allowed_groups => {},
errors => [],
rules => [], # desc of rules for --help
mutex => [], # rule: opts are mutually exclusive
atleast1 => [], # rule: at least one opt is required
disables => {}, # rule: opt disables other opts
defaults_to => {}, # rule: opt defaults to value of other opt
DSNParser => undef,
default_files => [
"/etc/percona-toolkit/percona-toolkit.conf",
"/etc/percona-toolkit/$program_name.conf",
"$home/.percona-toolkit.conf",
"$home/.$program_name.conf",
],
types => {
string => 's', # standard Getopt type
int => 'i', # standard Getopt type
float => 'f', # standard Getopt type
Hash => 'H', # hash, formed from a comma-separated list
hash => 'h', # hash as above, but only if a value is given
Array => 'A', # array, similar to Hash
array => 'a', # array, similar to hash
DSN => 'd', # DSN
size => 'z', # size with kMG suffix (powers of 2^10)
time => 'm', # time, with an optional suffix of s/h/m/d
},
};
return bless $self, $class;
}
sub get_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
my @specs = $self->_pod_to_specs($file);
$self->_parse_specs(@specs);
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
PTDEBUG && _d('Parsing DSN OPTIONS');
my $dsn_attribs = {
dsn => 1,
copy => 1,
};
my $parse_dsn_attribs = sub {
my ( $self, $option, $attribs ) = @_;
map {
my $val = $attribs->{$_};
if ( $val ) {
$val = $val eq 'yes' ? 1
: $val eq 'no' ? 0
: $val;
$attribs->{$_} = $val;
}
} keys %$attribs;
return {
key => $option,
%$attribs,
};
};
my $dsn_o = new OptionParser(
description => 'DSN OPTIONS',
head1 => 'DSN OPTIONS',
dsn => 0, # XXX don't infinitely recurse!
item => '\* (.)', # key opts are a single character
skip_rules => 1, # no rules before opts
attributes => $dsn_attribs,
parse_attributes => $parse_dsn_attribs,
);
my @dsn_opts = map {
my $opts = {
key => $_->{spec}->{key},
dsn => $_->{spec}->{dsn},
copy => $_->{spec}->{copy},
desc => $_->{desc},
};
$opts;
} $dsn_o->_pod_to_specs($file);
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
}
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
$self->{version} = $1;
PTDEBUG && _d($self->{version});
}
return;
}
sub DSNParser {
my ( $self ) = @_;
return $self->{DSNParser};
};
sub get_defaults_files {
my ( $self ) = @_;
return @{$self->{default_files}};
}
sub _pod_to_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
my @specs = ();
my @rules = ();
my $para;
local $INPUT_RECORD_SEPARATOR = '';
while ( $para = <$fh> ) {
next unless $para =~ m/^=head1 $self->{head1}/;
last;
}
while ( $para = <$fh> ) {
last if $para =~ m/^=over/;
next if $self->{skip_rules};
chomp $para;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
PTDEBUG && _d('Option rule:', $para);
push @rules, $para;
}
die "POD has no $self->{head1} section" unless $para;
do {
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
chomp $para;
PTDEBUG && _d($para);
my %attribs;
$para = <$fh>; # read next paragraph, possibly attributes
if ( $para =~ m/: / ) { # attributes
$para =~ s/\s+\Z//g;
%attribs = map {
my ( $attrib, $val) = split(/: /, $_);
die "Unrecognized attribute for --$option: $attrib"
unless $self->{attributes}->{$attrib};
($attrib, $val);
} split(/; /, $para);
if ( $attribs{'short form'} ) {
$attribs{'short form'} =~ s/-//;
}
$para = <$fh>; # read next paragraph, probably short help desc
}
else {
PTDEBUG && _d('Option has no attributes');
}
$para =~ s/\s+\Z//g;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
PTDEBUG && _d('Short help:', $para);
die "No description after option spec $option" if $para =~ m/^=item/;
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
$option = $base_option;
$attribs{'negatable'} = 1;
}
push @specs, {
spec => $self->{parse_attributes}->($self, $option, \%attribs),
desc => $para
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
};
}
while ( $para = <$fh> ) {
last unless $para;
if ( $para =~ m/^=head1/ ) {
$para = undef; # Can't 'last' out of a do {} block.
last;
}
last if $para =~ m/^=item /;
}
} while ( $para );
die "No valid specs in $self->{head1}" unless @specs;
close $fh;
return @specs, @rules;
}
sub _parse_specs {
my ( $self, @specs ) = @_;
my %disables; # special rule that requires deferred checking
foreach my $opt ( @specs ) {
if ( ref $opt ) { # It's an option spec, not a rule.
PTDEBUG && _d('Parsing opt spec:',
map { ($_, '=>', $opt->{$_}) } keys %$opt);
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
if ( !$long ) {
die "Cannot parse long option from spec $opt->{spec}";
}
$opt->{long} = $long;
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
$self->{opts}->{$long} = $opt;
if ( length $long == 1 ) {
PTDEBUG && _d('Long opt', $long, 'looks like short opt');
$self->{short_opts}->{$long} = $long;
}
if ( $short ) {
die "Duplicate short option -$short"
if exists $self->{short_opts}->{$short};
$self->{short_opts}->{$short} = $long;
$opt->{short} = $short;
}
else {
$opt->{short} = undef;
}
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
$opt->{group} ||= 'default';
$self->{groups}->{ $opt->{group} }->{$long} = 1;
$opt->{value} = undef;
$opt->{got} = 0;
my ( $type ) = $opt->{spec} =~ m/=(.)/;
$opt->{type} = $type;
PTDEBUG && _d($long, 'type:', $type);
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
$self->{defaults}->{$long} = defined $def ? $def : 1;
PTDEBUG && _d($long, 'default:', $def);
}
if ( $long eq 'config' ) {
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
}
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
$disables{$long} = $dis;
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
}
$self->{opts}->{$long} = $opt;
}
else { # It's an option rule, not a spec.
PTDEBUG && _d('Parsing rule:', $opt);
push @{$self->{rules}}, $opt;
my @participants = $self->_get_participants($opt);
my $rule_ok = 0;
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
$rule_ok = 1;
push @{$self->{mutex}}, \@participants;
PTDEBUG && _d(@participants, 'are mutually exclusive');
}
if ( $opt =~ m/at least one|one and only one/ ) {
$rule_ok = 1;
push @{$self->{atleast1}}, \@participants;
PTDEBUG && _d(@participants, 'require at least one');
}
if ( $opt =~ m/default to/ ) {
$rule_ok = 1;
$self->{defaults_to}->{$participants[0]} = $participants[1];
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
}
if ( $opt =~ m/restricted to option groups/ ) {
$rule_ok = 1;
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
my @groups = split(',', $groups);
%{$self->{allowed_groups}->{$participants[0]}} = map {
s/\s+//;
$_ => 1;
} @groups;
}
if( $opt =~ m/accepts additional command-line arguments/ ) {
$rule_ok = 1;
$self->{strict} = 0;
PTDEBUG && _d("Strict mode disabled by rule");
}
die "Unrecognized option rule: $opt" unless $rule_ok;
}
}
foreach my $long ( keys %disables ) {
my @participants = $self->_get_participants($disables{$long});
$self->{disables}->{$long} = \@participants;
PTDEBUG && _d('Option', $long, 'disables', @participants);
}
return;
}
sub _get_participants {
my ( $self, $str ) = @_;
my @participants;
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
die "Option --$long does not exist while processing rule $str"
unless exists $self->{opts}->{$long};
push @participants, $long;
}
PTDEBUG && _d('Participants for', $str, ':', @participants);
return @participants;
}
sub opts {
my ( $self ) = @_;
my %opts = %{$self->{opts}};
return %opts;
}
sub short_opts {
my ( $self ) = @_;
my %short_opts = %{$self->{short_opts}};
return %short_opts;
}
sub set_defaults {
my ( $self, %defaults ) = @_;
$self->{defaults} = {};
foreach my $long ( keys %defaults ) {
die "Cannot set default for nonexistent option $long"
unless exists $self->{opts}->{$long};
$self->{defaults}->{$long} = $defaults{$long};
PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
}
return;
}
sub get_defaults {
my ( $self ) = @_;
return $self->{defaults};
}
sub get_groups {
my ( $self ) = @_;
return $self->{groups};
}
sub _set_option {
my ( $self, $opt, $val ) = @_;
my $long = exists $self->{opts}->{$opt} ? $opt
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
: die "Getopt::Long gave a nonexistent option: $opt";
$opt = $self->{opts}->{$long};
if ( $opt->{is_cumulative} ) {
$opt->{value}++;
}
elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
my $next_opt = $1;
if ( exists $self->{opts}->{$next_opt}
|| exists $self->{short_opts}->{$next_opt} ) {
$self->save_error("--$long requires a string value");
return;
}
else {
$opt->{value} = $val;
}
}
else {
$opt->{value} = $val;
}
$opt->{got} = 1;
PTDEBUG && _d('Got option', $long, '=', $val);
}
sub get_opts {
my ( $self ) = @_;
foreach my $long ( keys %{$self->{opts}} ) {
$self->{opts}->{$long}->{got} = 0;
$self->{opts}->{$long}->{value}
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
: $self->{opts}->{$long}->{is_cumulative} ? 0
: undef;
}
$self->{got_opts} = 0;
$self->{errors} = [];
if ( @ARGV && $ARGV[0] eq "--config" ) {
shift @ARGV;
$self->_set_option('config', shift @ARGV);
}
if ( $self->has('config') ) {
my @extra_args;
foreach my $filename ( split(',', $self->get('config')) ) {
eval {
push @extra_args, $self->_read_config_file($filename);
};
if ( $EVAL_ERROR ) {
if ( $self->got('config') ) {
die $EVAL_ERROR;
}
elsif ( PTDEBUG ) {
_d($EVAL_ERROR);
}
}
}
unshift @ARGV, @extra_args;
}
Getopt::Long::Configure('no_ignore_case', 'bundling');
GetOptions(
map { $_->{spec} => sub { $self->_set_option(@_); } }
grep { $_->{long} ne 'config' } # --config is handled specially above.
values %{$self->{opts}}
) or $self->save_error('Error parsing options');
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
if ( $self->{version} ) {
print $self->{version}, "\n";
}
else {
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
}
exit 1;
}
if ( @ARGV && $self->{strict} ) {
$self->save_error("Unrecognized command-line options @ARGV");
}
foreach my $mutex ( @{$self->{mutex}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
if ( @set > 1 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
. ' are mutually exclusive.';
$self->save_error($err);
}
}
foreach my $required ( @{$self->{atleast1}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
if ( @set == 0 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$required}[ 0 .. scalar(@$required) - 2] )
.' or --'.$self->{opts}->{$required->[-1]}->{long};
$self->save_error("Specify at least one of $err");
}
}
$self->_check_opts( keys %{$self->{opts}} );
$self->{got_opts} = 1;
return;
}
sub _check_opts {
my ( $self, @long ) = @_;
my $long_last = scalar @long;
while ( @long ) {
foreach my $i ( 0..$#long ) {
my $long = $long[$i];
next unless $long;
my $opt = $self->{opts}->{$long};
if ( $opt->{got} ) {
if ( exists $self->{disables}->{$long} ) {
my @disable_opts = @{$self->{disables}->{$long}};
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
PTDEBUG && _d('Unset options', @disable_opts,
'because', $long,'disables them');
}
if ( exists $self->{allowed_groups}->{$long} ) {
my @restricted_groups = grep {
!exists $self->{allowed_groups}->{$long}->{$_}
} keys %{$self->{groups}};
my @restricted_opts;
foreach my $restricted_group ( @restricted_groups ) {
RESTRICTED_OPT:
foreach my $restricted_opt (
keys %{$self->{groups}->{$restricted_group}} )
{
next RESTRICTED_OPT if $restricted_opt eq $long;
push @restricted_opts, $restricted_opt
if $self->{opts}->{$restricted_opt}->{got};
}
}
if ( @restricted_opts ) {
my $err;
if ( @restricted_opts == 1 ) {
$err = "--$restricted_opts[0]";
}
else {
$err = join(', ',
map { "--$self->{opts}->{$_}->{long}" }
grep { $_ }
@restricted_opts[0..scalar(@restricted_opts) - 2]
)
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
}
$self->save_error("--$long is not allowed with $err");
}
}
}
elsif ( $opt->{is_required} ) {
$self->save_error("Required option --$long must be specified");
}
$self->_validate_type($opt);
if ( $opt->{parsed} ) {
delete $long[$i];
}
else {
PTDEBUG && _d('Temporarily failed to parse', $long);
}
}
die "Failed to parse options, possibly due to circular dependencies"
if @long == $long_last;
$long_last = @long;
}
return;
}
sub _validate_type {
my ( $self, $opt ) = @_;
return unless $opt;
if ( !$opt->{type} ) {
$opt->{parsed} = 1;
return;
}
my $val = $opt->{value};
if ( $val && $opt->{type} eq 'm' ) { # type time
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
if ( !$suffix ) {
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
$suffix = $s || 's';
PTDEBUG && _d('No suffix given; using', $suffix, 'for',
$opt->{long}, '(value:', $val, ')');
}
if ( $suffix =~ m/[smhd]/ ) {
$val = $suffix eq 's' ? $num # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$opt->{value} = ($prefix || '') . $val;
PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
}
else {
$self->save_error("Invalid time suffix for --$opt->{long}");
}
}
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
my $prev = {};
my $from_key = $self->{defaults_to}->{ $opt->{long} };
if ( $from_key ) {
PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
if ( $self->{opts}->{$from_key}->{parsed} ) {
$prev = $self->{opts}->{$from_key}->{value};
}
else {
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
$from_key, 'parsed');
return;
}
}
my $defaults = $self->{DSNParser}->parse_options($self);
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
}
elsif ( $val && $opt->{type} eq 'z' ) { # type size
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
$self->_parse_size($opt, $val);
}
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
}
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
}
else {
PTDEBUG && _d('Nothing to validate for option',
$opt->{long}, 'type', $opt->{type}, 'value', $val);
}
$opt->{parsed} = 1;
return;
}
sub get {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{value};
}
sub got {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{got};
}
sub has {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
return defined $long ? exists $self->{opts}->{$long} : 0;
}
sub set {
my ( $self, $opt, $val ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
$self->{opts}->{$long}->{value} = $val;
return;
}
sub save_error {
my ( $self, $error ) = @_;
push @{$self->{errors}}, $error;
return;
}
sub errors {
my ( $self ) = @_;
return $self->{errors};
}
sub usage {
my ( $self ) = @_;
warn "No usage string is set" unless $self->{usage}; # XXX
return "Usage: " . ($self->{usage} || '') . "\n";
}
sub descr {
my ( $self ) = @_;
warn "No description string is set" unless $self->{description}; # XXX
my $descr = ($self->{description} || $self->{program_name} || '')
. " For more details, please use the --help option, "
. "or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation.";
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
unless $ENV{DONT_BREAK_LINES};
$descr =~ s/ +$//mg;
return $descr;
}
sub usage_or_errors {
my ( $self, $file, $return ) = @_;
$file ||= $self->{file} || __FILE__;
if ( !$self->{description} || !$self->{usage} ) {
PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
my %synop = $self->_parse_synopsis($file);
$self->{description} ||= $synop{description};
$self->{usage} ||= $synop{usage};
PTDEBUG && _d("Description:", $self->{description},
"\nUsage:", $self->{usage});
}
if ( $self->{opts}->{help}->{got} ) {
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
exit 0 unless $return;
}
elsif ( scalar @{$self->{errors}} ) {
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
exit 1 unless $return;
}
return;
}
sub print_errors {
my ( $self ) = @_;
my $usage = $self->usage() . "\n";
if ( (my @errors = @{$self->{errors}}) ) {
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
. "\n";
}
return $usage . "\n" . $self->descr();
}
sub print_usage {
my ( $self ) = @_;
die "Run get_opts() before print_usage()" unless $self->{got_opts};
my @opts = values %{$self->{opts}};
my $maxl = max(
map {
length($_->{long}) # option long name
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
}
@opts);
my $maxs = max(0,
map {
length($_)
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
}
values %{$self->{short_opts}});
my $lcol = max($maxl, ($maxs + 3));
my $rcol = 80 - $lcol - 6;
my $rpad = ' ' x ( 80 - $rcol );
$maxs = max($lcol - 3, $maxs);
my $usage = $self->descr() . "\n" . $self->usage();
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
push @groups, 'default';
foreach my $group ( reverse @groups ) {
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
foreach my $opt (
sort { $a->{long} cmp $b->{long} }
grep { $_->{group} eq $group }
@opts )
{
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
my $short = $opt->{short};
my $desc = $opt->{desc};
$long .= $opt->{type} ? "=$opt->{type}" : "";
if ( $opt->{type} && $opt->{type} eq 'm' ) {
my ($s) = $desc =~ m/\(suffix (.)\)/;
$s ||= 's';
$desc =~ s/\s+\(suffix .\)//;
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
. "d=days; if no suffix, $s is used.";
}
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
$desc =~ s/ +$//mg;
if ( $short ) {
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
}
else {
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
}
}
}
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
if ( (my @rules = @{$self->{rules}}) ) {
$usage .= "\nRules:\n\n";
$usage .= join("\n", map { " $_" } @rules) . "\n";
}
if ( $self->{DSNParser} ) {
$usage .= "\n" . $self->{DSNParser}->usage();
}
$usage .= "\nOptions and values after processing arguments:\n\n";
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
my $val = $opt->{value};
my $type = $opt->{type} || '';
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
: !defined $val ? '(No value)'
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
: $type =~ m/H|h/ ? join(',', sort keys %$val)
: $type =~ m/A|a/ ? join(',', @$val)
: $val;
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
}
return $usage;
}
sub prompt_noecho {
shift @_ if ref $_[0] eq __PACKAGE__;
my ( $prompt ) = @_;
local $OUTPUT_AUTOFLUSH = 1;
print STDERR $prompt
or die "Cannot print: $OS_ERROR";
my $response;
eval {
require Term::ReadKey;
Term::ReadKey::ReadMode('noecho');
chomp($response = <STDIN>);
Term::ReadKey::ReadMode('normal');
print "\n"
or die "Cannot print: $OS_ERROR";
};
if ( $EVAL_ERROR ) {
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
}
return $response;
}
sub _read_config_file {
my ( $self, $filename ) = @_;
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
my @args;
my $prefix = '--';
my $parse = 1;
LINE:
while ( my $line = <$fh> ) {
chomp $line;
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
$line =~ s/\s+#.*$//g;
$line =~ s/^\s+|\s+$//g;
if ( $line eq '--' ) {
$prefix = '';
$parse = 0;
next LINE;
}
if ( $parse
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
) {
push @args, grep { defined $_ } ("$prefix$opt", $arg);
}
elsif ( $line =~ m/./ ) {
push @args, $line;
}
else {
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
}
}
close $fh;
return @args;
}
sub read_para_after {
my ( $self, $file, $regex ) = @_;
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = '';
my $para;
while ( $para = <$fh> ) {
next unless $para =~ m/^=pod$/m;
last;
}
while ( $para = <$fh> ) {
next unless $para =~ m/$regex/;
last;
}
$para = <$fh>;
chomp($para);
close $fh or die "Can't close $file: $OS_ERROR";
return $para;
}
sub clone {
my ( $self ) = @_;
my %clone = map {
my $hashref = $self->{$_};
my $val_copy = {};
foreach my $key ( keys %$hashref ) {
my $ref = ref $hashref->{$key};
$val_copy->{$key} = !$ref ? $hashref->{$key}
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
: $hashref->{$key};
}
$_ => $val_copy;
} qw(opts short_opts defaults);
foreach my $scalar ( qw(got_opts) ) {
$clone{$scalar} = $self->{$scalar};
}
return bless \%clone;
}
sub _parse_size {
my ( $self, $opt, $val ) = @_;
if ( lc($val || '') eq 'null' ) {
PTDEBUG && _d('NULL size for', $opt->{long});
$opt->{value} = 'null';
return;
}
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
if ( defined $num ) {
if ( $factor ) {
$num *= $factor_for{$factor};
PTDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}: $val");
}
return;
}
sub _parse_attribs {
my ( $self, $option, $attribs ) = @_;
my $types = $self->{types};
return $option
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
. ($attribs->{'negatable'} ? '!' : '' )
. ($attribs->{'cumulative'} ? '+' : '' )
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
}
sub _parse_synopsis {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
die "$file does not contain a SYNOPSIS section" unless $para;
my @synop;
for ( 1..2 ) { # 1 for the usage, 2 for the description
my $para = <$fh>;
push @synop, $para;
}
close $fh;
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
my ($usage, $desc) = @synop;
die "The SYNOPSIS section in $file is not formatted properly"
unless $usage && $desc;
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
chomp $usage;
$desc =~ s/\n/ /g;
$desc =~ s/\s{2,}/ /g;
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
$desc =~ s/\s+$//;
return (
description => $desc,
usage => $usage,
);
};
sub set_vars {
my ($self, $file) = @_;
$file ||= $self->{file} || __FILE__;
my %user_vars;
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
if ( $user_vars ) {
foreach my $var_val ( @$user_vars ) {
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$user_vars{$var} = {
val => $val,
default => 0,
};
}
}
my %default_vars;
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
if ( $default_vars ) {
%default_vars = map {
my $var_val = $_;
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$var => {
val => $val,
default => 1,
};
} split("\n", $default_vars);
}
my %vars = (
%default_vars, # first the tool's defaults
%user_vars, # then the user's which overwrite the defaults
);
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
return \%vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
if ( PTDEBUG ) {
print STDERR '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print STDERR "# $uname\n";
}
print STDERR '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# ###########################################################################
# DSNParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DSNParser.pm
# t/lib/DSNParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DSNParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Quotekeys = 0;
my $dsn_sep = qr/(?<!\\),/;
eval {
require DBI;
};
my $have_dbi = $EVAL_ERROR ? 0 : 1;
sub new {
my ( $class, %args ) = @_;
foreach my $arg ( qw(opts) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
};
foreach my $opt ( @{$args{opts}} ) {
if ( !$opt->{key} || !$opt->{desc} ) {
die "Invalid DSN option: ", Dumper($opt);
}
PTDEBUG && _d('DSN option:',
join(', ',
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
keys %$opt
)
);
$self->{opts}->{$opt->{key}} = {
dsn => $opt->{dsn},
desc => $opt->{desc},
copy => $opt->{copy} || 0,
};
}
return bless $self, $class;
}
sub prop {
my ( $self, $prop, $value ) = @_;
if ( @_ > 2 ) {
PTDEBUG && _d('Setting', $prop, 'property');
$self->{$prop} = $value;
}
return $self->{$prop};
}
sub parse {
my ( $self, $dsn, $prev, $defaults ) = @_;
if ( !$dsn ) {
PTDEBUG && _d('No DSN to parse');
return;
}
PTDEBUG && _d('Parsing', $dsn);
$prev ||= {};
$defaults ||= {};
my %given_props;
my %final_props;
my $opts = $self->{opts};
foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
$dsn_part =~ s/\\,/,/g;
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
$given_props{$prop_key} = $prop_val;
}
else {
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
$given_props{h} = $dsn_part;
}
}
foreach my $key ( keys %$opts ) {
PTDEBUG && _d('Finding value for', $key);
$final_props{$key} = $given_props{$key};
if ( !defined $final_props{$key}
&& defined $prev->{$key} && $opts->{$key}->{copy} )
{
$final_props{$key} = $prev->{$key};
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
}
if ( !defined $final_props{$key} ) {
$final_props{$key} = $defaults->{$key};
PTDEBUG && _d('Copying value for', $key, 'from defaults');
}
}
foreach my $key ( keys %given_props ) {
die "Unknown DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless exists $opts->{$key};
}
if ( (my $required = $self->prop('required')) ) {
foreach my $key ( keys %$required ) {
die "Missing required DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless $final_props{$key};
}
}
return \%final_props;
}
sub parse_options {
my ( $self, $o ) = @_;
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
my $dsn_string
= join(',',
map { "$_=".$o->get($_); }
grep { $o->has($_) && $o->get($_) }
keys %{$self->{opts}}
);
PTDEBUG && _d('DSN string made from options:', $dsn_string);
return $self->parse($dsn_string);
}
sub as_string {
my ( $self, $dsn, $props ) = @_;
return $dsn unless ref $dsn;
my @keys = $props ? @$props : sort keys %$dsn;
return join(',',
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
grep {
exists $self->{opts}->{$_}
&& exists $dsn->{$_}
&& defined $dsn->{$_}
} @keys);
}
sub usage {
my ( $self ) = @_;
my $usage
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
. " KEY COPY MEANING\n"
. " === ==== =============================================\n";
my %opts = %{$self->{opts}};
foreach my $key ( sort keys %opts ) {
$usage .= " $key "
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
. ($opts{$key}->{desc} || '[No description]')
. "\n";
}
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
return $usage;
}
sub get_cxn_params {
my ( $self, $info ) = @_;
my $dsn;
my %opts = %{$self->{opts}};
my $driver = $self->prop('dbidriver') || '';
if ( $driver eq 'Pg' ) {
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(h P));
}
else {
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(F h P S A))
. ';mysql_read_default_group=client'
. ($info->{L} ? ';mysql_local_infile=1' : '');
}
PTDEBUG && _d($dsn);
return ($dsn, $info->{u}, $info->{p});
}
sub fill_in_dsn {
my ( $self, $dbh, $dsn ) = @_;
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
$user =~ s/@.*//;
$dsn->{h} ||= $vars->{hostname}->{Value};
$dsn->{S} ||= $vars->{'socket'}->{Value};
$dsn->{P} ||= $vars->{port}->{Value};
$dsn->{u} ||= $user;
$dsn->{D} ||= $db;
}
sub get_dbh {
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
$opts ||= {};
my $defaults = {
AutoCommit => 0,
RaiseError => 1,
PrintError => 0,
ShowErrorStatement => 1,
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
};
@{$defaults}{ keys %$opts } = values %$opts;
if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
$defaults->{mysql_local_infile} = 1;
}
if ( $opts->{mysql_use_result} ) {
$defaults->{mysql_use_result} = 1;
}
if ( !$have_dbi ) {
die "Cannot connect to MySQL because the Perl DBI module is not "
. "installed or not found. Run 'perl -MDBI' to see the directories "
. "that Perl searches for DBI. If DBI is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbi-perl\n"
. " RHEL/CentOS yum install perl-DBI\n"
. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
}
my $dbh;
my $tries = 2;
while ( !$dbh && $tries-- ) {
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
if ( !$dbh && $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
. "the directories that Perl searches for DBD::mysql. If "
. "DBD::mysql is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
}
elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
PTDEBUG && _d('Going to try again without utf8 support');
delete $defaults->{mysql_enable_utf8};
}
if ( !$tries ) {
die $EVAL_ERROR;
}
}
}
if ( $cxn_string =~ m/mysql/i ) {
my $sql;
$sql = 'SELECT @@SQL_MODE';
PTDEBUG && _d($dbh, $sql);
my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
die "Error getting the current SQL_MODE: $EVAL_ERROR";
}
if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
$sql = qq{/*!40101 SET NAMES "$charset"*/};
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting NAMES to $charset: $EVAL_ERROR";
}
PTDEBUG && _d('Enabling charset for STDOUT');
if ( $charset eq 'utf8' ) {
binmode(STDOUT, ':utf8')
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
}
else {
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
}
}
if ( my $vars = $self->prop('set-vars') ) {
$self->set_vars($dbh, $vars);
}
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
. ($sql_mode ? ",$sql_mode" : '')
. '\'*/';
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
. ($sql_mode ? " and $sql_mode" : '')
. ": $EVAL_ERROR";
}
}
PTDEBUG && _d('DBH info: ',
$dbh,
Dumper($dbh->selectrow_hashref(
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
'Connection info:', $dbh->{mysql_hostinfo},
'Character set info:', Dumper($dbh->selectall_arrayref(
"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
'$DBI::VERSION:', $DBI::VERSION,
);
return $dbh;
}
sub get_hostname {
my ( $self, $dbh ) = @_;
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
return $host;
}
my ( $hostname, $one ) = $dbh->selectrow_array(
'SELECT /*!50038 @@hostname, */ 1');
return $hostname;
}
sub disconnect {
my ( $self, $dbh ) = @_;
PTDEBUG && $self->print_active_handles($dbh);
$dbh->disconnect;
}
sub print_active_handles {
my ( $self, $thing, $level ) = @_;
$level ||= 0;
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
or die "Cannot print: $OS_ERROR";
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
$self->print_active_handles( $handle, $level + 1 );
}
}
sub copy {
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
die 'I need a dsn_1 argument' unless $dsn_1;
die 'I need a dsn_2 argument' unless $dsn_2;
my %new_dsn = map {
my $key = $_;
my $val;
if ( $args{overwrite} ) {
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
}
else {
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
}
$key => $val;
} keys %{$self->{opts}};
return \%new_dsn;
}
sub set_vars {
my ($self, $dbh, $vars) = @_;
return unless $vars;
foreach my $var ( sort keys %$vars ) {
my $val = $vars->{$var}->{val};
(my $quoted_var = $var) =~ s/_/\\_/;
my ($var_exists, $current_val);
eval {
($var_exists, $current_val) = $dbh->selectrow_array(
"SHOW VARIABLES LIKE '$quoted_var'");
};
my $e = $EVAL_ERROR;
if ( $e ) {
PTDEBUG && _d($e);
}
if ( $vars->{$var}->{default} && !$var_exists ) {
PTDEBUG && _d('Not setting default var', $var,
'because it does not exist');
next;
}
if ( $current_val && $current_val eq $val ) {
PTDEBUG && _d('Not setting var', $var, 'because its value',
'is already', $val);
next;
}
my $sql = "SET SESSION $var=$val";
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( my $set_error = $EVAL_ERROR ) {
chomp($set_error);
$set_error =~ s/ at \S+ line \d+//;
my $msg = "Error setting $var: $set_error";
if ( $current_val ) {
$msg .= " The current value for $var is $current_val. "
. "If the variable is read only (not dynamic), specify "
. "--set-vars $var=$current_val to avoid this warning, "
. "else manually set the variable and restart MySQL.";
}
warn $msg . "\n\n";
}
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End DSNParser package
# ###########################################################################
# ###########################################################################
# Cxn package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Cxn.pm
# t/lib/Cxn.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Cxn;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Scalar::Util qw(blessed);
use constant {
PTDEBUG => $ENV{PTDEBUG} || 0,
PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
};
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(DSNParser OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my ($dp, $o) = @args{@required_args};
my $dsn_defaults = $dp->parse_options($o);
my $prev_dsn = $args{prev_dsn};
my $dsn = $args{dsn};
if ( !$dsn ) {
$args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
$dsn = $dp->parse(
$args{dsn_string}, $prev_dsn, $dsn_defaults);
}
elsif ( $prev_dsn ) {
$dsn = $dp->copy($prev_dsn, $dsn);
}
my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
|| $dp->as_string($dsn, [qw(F)])
|| '';
my $self = {
dsn => $dsn,
dbh => $args{dbh},
dsn_name => $dsn_name,
hostname => '',
set => $args{set},
NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
dbh_set => 0,
ask_pass => $o->get('ask-pass'),
DSNParser => $dp,
is_cluster_node => undef,
parent => $args{parent},
};
return bless $self, $class;
}
sub connect {
my ( $self, %opts ) = @_;
my $dsn = $opts{dsn} || $self->{dsn};
my $dp = $self->{DSNParser};
my $dbh = $self->{dbh};
if ( !$dbh || !$dbh->ping() ) {
if ( $self->{ask_pass} && !$self->{asked_for_pass} && !defined $dsn->{p} ) {
$dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: ");
$self->{asked_for_pass} = 1;
}
$dbh = $dp->get_dbh(
$dp->get_cxn_params($dsn),
{
AutoCommit => 1,
%opts,
},
);
}
$dbh = $self->set_dbh($dbh);
if ( $opts{dsn} ) {
$self->{dsn} = $dsn;
$self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
|| $dp->as_string($dsn, [qw(F)])
|| '';
}
PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
return $dbh;
}
sub set_dbh {
my ($self, $dbh) = @_;
if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
PTDEBUG && _d($dbh, 'Already set dbh');
return $dbh;
}
PTDEBUG && _d($dbh, 'Setting dbh');
$dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/';
PTDEBUG && _d($dbh, $sql);
my ($server_id, $hostname) = $dbh->selectrow_array($sql);
PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id);
if ( $hostname ) {
$self->{hostname} = $hostname;
}
if ( $self->{parent} ) {
PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
$dbh->{InactiveDestroy} = 1;
}
if ( my $set = $self->{set}) {
$set->($dbh);
}
$self->{dbh} = $dbh;
$self->{dbh_set} = 1;
return $dbh;
}
sub lost_connection {
my ($self, $e) = @_;
return 0 unless $e;
return $e =~ m/MySQL server has gone away/
|| $e =~ m/Lost connection to MySQL server/;
}
sub dbh {
my ($self) = @_;
return $self->{dbh};
}
sub dsn {
my ($self) = @_;
return $self->{dsn};
}
sub name {
my ($self) = @_;
return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
return $self->{hostname} || $self->{dsn_name} || 'unknown host';
}
sub get_id {
my ($self, $cxn) = @_;
$cxn ||= $self;
my $unique_id;
if ($cxn->is_cluster_node()) { # for cluster we concatenate various variables to maximize id 'uniqueness' across versions
my $sql = q{SHOW STATUS LIKE 'wsrep\_local\_index'};
my (undef, $wsrep_local_index) = $cxn->dbh->selectrow_array($sql);
PTDEBUG && _d("Got cluster wsrep_local_index: ",$wsrep_local_index);
$unique_id = $wsrep_local_index."|";
foreach my $val ('server\_id', 'wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') {
my $sql = "SHOW VARIABLES LIKE '$val'";
PTDEBUG && _d($cxn->name, $sql);
my (undef, $val) = $cxn->dbh->selectrow_array($sql);
$unique_id .= "|$val";
}
} else {
my $sql = 'SELECT @@SERVER_ID';
PTDEBUG && _d($sql);
$unique_id = $cxn->dbh->selectrow_array($sql);
}
PTDEBUG && _d("Generated unique id for cluster:", $unique_id);
return $unique_id;
}
sub is_cluster_node {
my ($self, $cxn) = @_;
$cxn ||= $self;
my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'";
PTDEBUG && _d($cxn->name, $sql);
my $row = $cxn->dbh->selectrow_arrayref($sql);
return $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1') ? 1 : 0;
}
sub remove_duplicate_cxns {
my ($self, %args) = @_;
my @cxns = @{$args{cxns}};
my $seen_ids = $args{seen_ids} || {};
PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns));
my @trimmed_cxns;
for my $cxn ( @cxns ) {
my $id = $cxn->get_id();
PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
if ( ! $seen_ids->{$id}++ ) {
push @trimmed_cxns, $cxn
}
else {
PTDEBUG && _d("Removing ", $cxn->name,
", ID ", $id, ", because we've already seen it");
}
}
return \@trimmed_cxns;
}
sub DESTROY {
my ($self) = @_;
PTDEBUG && _d('Destroying cxn');
if ( $self->{parent} ) {
PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
}
elsif ( $self->{dbh}
&& blessed($self->{dbh})
&& $self->{dbh}->can("disconnect") )
{
PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
$self->{dsn_name});
$self->{dbh}->disconnect();
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Cxn package
# ###########################################################################
# ###########################################################################
# Daemon package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Daemon.pm
# t/lib/Daemon.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Daemon;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use POSIX qw(setsid);
sub new {
my ( $class, %args ) = @_;
foreach my $arg ( qw(o) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $o = $args{o};
my $self = {
o => $o,
log_file => $o->has('log') ? $o->get('log') : undef,
PID_file => $o->has('pid') ? $o->get('pid') : undef,
};
check_PID_file(undef, $self->{PID_file});
PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
return bless $self, $class;
}
sub daemonize {
my ( $self ) = @_;
PTDEBUG && _d('About to fork and daemonize');
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
if ( $pid ) {
PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
exit;
}
PTDEBUG && _d('Daemonizing child PID', $PID);
$self->{PID_owner} = $PID;
$self->{child} = 1;
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
$self->_make_PID_file();
$OUTPUT_AUTOFLUSH = 1;
PTDEBUG && _d('Redirecting STDIN to /dev/null');
close STDIN;
open STDIN, '/dev/null'
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
if ( $self->{log_file} ) {
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
close STDOUT;
open STDOUT, '>>', $self->{log_file}
or die "Cannot open log file $self->{log_file}: $OS_ERROR";
close STDERR;
open STDERR, ">&STDOUT"
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
}
else {
if ( -t STDOUT ) {
PTDEBUG && _d('No log file and STDOUT is a terminal;',
'redirecting to /dev/null');
close STDOUT;
open STDOUT, '>', '/dev/null'
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
}
if ( -t STDERR ) {
PTDEBUG && _d('No log file and STDERR is a terminal;',
'redirecting to /dev/null');
close STDERR;
open STDERR, '>', '/dev/null'
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
}
}
return;
}
sub check_PID_file {
my ( $self, $file ) = @_;
my $PID_file = $self ? $self->{PID_file} : $file;
PTDEBUG && _d('Checking PID file', $PID_file);
if ( $PID_file && -f $PID_file ) {
my $pid;
eval {
chomp($pid = (slurp_file($PID_file) || ''));
};
if ( $EVAL_ERROR ) {
die "The PID file $PID_file already exists but it cannot be read: "
. $EVAL_ERROR;
}
PTDEBUG && _d('PID file exists; it contains PID', $pid);
if ( $pid ) {
my $pid_is_alive = kill 0, $pid;
if ( $pid_is_alive ) {
die "The PID file $PID_file already exists "
. " and the PID that it contains, $pid, is running";
}
else {
warn "Overwriting PID file $PID_file because the PID that it "
. "contains, $pid, is not running";
}
}
else {
die "The PID file $PID_file already exists but it does not "
. "contain a PID";
}
}
else {
PTDEBUG && _d('No PID file');
}
return;
}
sub make_PID_file {
my ( $self ) = @_;
if ( exists $self->{child} ) {
die "Do not call Daemon::make_PID_file() for daemonized scripts";
}
$self->_make_PID_file();
$self->{PID_owner} = $PID;
return;
}
sub _make_PID_file {
my ( $self ) = @_;
my $PID_file = $self->{PID_file};
if ( !$PID_file ) {
PTDEBUG && _d('No PID file to create');
return;
}
$self->check_PID_file();
open my $PID_FH, '>', $PID_file
or die "Cannot open PID file $PID_file: $OS_ERROR";
print $PID_FH $PID
or die "Cannot print to PID file $PID_file: $OS_ERROR";
close $PID_FH
or die "Cannot close PID file $PID_file: $OS_ERROR";
PTDEBUG && _d('Created PID file:', $self->{PID_file});
return;
}
sub _remove_PID_file {
my ( $self ) = @_;
if ( $self->{PID_file} && -f $self->{PID_file} ) {
unlink $self->{PID_file}
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
PTDEBUG && _d('Removed PID file');
}
else {
PTDEBUG && _d('No PID to remove');
}
return;
}
sub DESTROY {
my ( $self ) = @_;
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
return;
}
sub slurp_file {
my ($file) = @_;
return unless $file;
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
return do { local $/; <$fh> };
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Daemon package
# ###########################################################################
# ###########################################################################
# TextResultSetParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/TextResultSetParser.pm
# t/lib/TextResultSetParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package TextResultSetParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my %value_for = (
'NULL' => undef, # DBI::selectall_arrayref() does this
($args{value_for} ? %{$args{value_for}} : ()),
);
my $self = {
%args,
value_for => \%value_for,
};
return bless $self, $class;
}
sub _parse_tabular {
my ( $text, @cols ) = @_;
my %row;
my @vals = $text =~ m/\| +([^\|]*?)(?= +\|)/msg;
return (undef, \@vals) unless @cols;
@row{@cols} = @vals;
return (\%row, undef);
}
sub _parse_tab_sep {
my ( $text, @cols ) = @_;
my %row;
my @vals = split(/\t/, $text);
return (undef, \@vals) unless @cols;
@row{@cols} = @vals;
return (\%row, undef);
}
sub parse_vertical_row {
my ( $self, $text ) = @_;
my %row = $text =~ m/^\s*(\w+):(?: ([^\n]*))?/msg;
if ( $self->{NAME_lc} ) {
my %lc_row = map {
my $key = lc $_;
$key => $row{$_};
} keys %row;
return \%lc_row;
}
else {
return \%row;
}
}
sub parse {
my ( $self, $text ) = @_;
my $result_set;
if ( $text =~ m/^\+---/m ) { # standard "tabular" output
PTDEBUG && _d('Result set text is standard tabular');
my $line_pattern = qr/^(\| .*)[\r\n]+/m;
$result_set
= $self->parse_horizontal_row($text, $line_pattern, \&_parse_tabular);
}
elsif ( $text =~ m/^\w+\t\w+/m ) { # tab-separated
PTDEBUG && _d('Result set text is tab-separated');
my $line_pattern = qr/^(.*?\t.*)[\r\n]+/m;
$result_set
= $self->parse_horizontal_row($text, $line_pattern, \&_parse_tab_sep);
}
elsif ( $text =~ m/\*\*\* \d+\. row/ ) { # "vertical" output
PTDEBUG && _d('Result set text is vertical (\G)');
foreach my $row ( split_vertical_rows($text) ) {
push @$result_set, $self->parse_vertical_row($row);
}
}
else {
my $text_sample = substr $text, 0, 300;
my $remaining = length $text > 300 ? (length $text) - 300 : 0;
chomp $text_sample;
die "Cannot determine if text is tabular, tab-separated or vertical:\n"
. "$text_sample\n"
. ($remaining ? "(not showing last $remaining bytes of text)\n" : "");
}
if ( $self->{value_for} ) {
foreach my $result_set ( @$result_set ) {
foreach my $key ( keys %$result_set ) {
next unless defined $result_set->{$key};
$result_set->{$key} = $self->{value_for}->{ $result_set->{$key} }
if exists $self->{value_for}->{ $result_set->{$key} };
}
}
}
return $result_set;
}
sub parse_horizontal_row {
my ( $self, $text, $line_pattern, $sub ) = @_;
my @result_sets = ();
my @cols = ();
foreach my $line ( $text =~ m/$line_pattern/g ) {
my ( $row, $cols ) = $sub->($line, @cols);
if ( $row ) {
push @result_sets, $row;
}
else {
@cols = map { $self->{NAME_lc} ? lc $_ : $_ } @$cols;
}
}
return \@result_sets;
}
sub split_vertical_rows {
my ( $text ) = @_;
my $ROW_HEADER = '\*{3,} \d+\. row \*{3,}';
my @rows = $text =~ m/($ROW_HEADER.*?)(?=$ROW_HEADER|\z)/omgs;
return @rows;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End TextResultSetParser package
# ###########################################################################
# ###########################################################################
# MySQLConfig package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MySQLConfig.pm
# t/lib/MySQLConfig.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MySQLConfig;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
my %can_be_duplicate = (
replicate_wild_do_table => 1,
replicate_wild_ignore_table => 1,
replicate_rewrite_db => 1,
replicate_ignore_table => 1,
replicate_ignore_db => 1,
replicate_do_table => 1,
replicate_do_db => 1,
);
sub new {
my ( $class, %args ) = @_;
my @requires_one_of = qw(file output result_set dbh);
my $required_arg = grep { $args{$_} } @requires_one_of;
if ( !$required_arg ) {
die "I need a " . join(', ', @requires_one_of[0..$#requires_one_of-1])
. " or " . $requires_one_of[-1] . " argument";
}
if ( $required_arg > 1 ) {
die "Specify only one "
. join(', ', @requires_one_of[0..$#requires_one_of-1])
. " or " . $requires_one_of[-1] . " argument";
}
if ( $args{file} || $args{output} ) {
die "I need a TextResultSetParser argument"
unless $args{TextResultSetParser};
}
if ( $args{file} ) {
$args{output} = _slurp_file($args{file});
}
my %config_data = _parse_config(%args);
my $self = {
%args,
%config_data,
};
return bless $self, $class;
}
sub _parse_config {
my ( %args ) = @_;
my %config_data;
if ( $args{output} ) {
%config_data = _parse_config_output(%args);
}
elsif ( my $rows = $args{result_set} ) {
$config_data{format} = $args{format} || 'show_variables';
$config_data{vars} = { map { @$_ } @$rows };
}
elsif ( my $dbh = $args{dbh} ) {
$config_data{format} = $args{format} || 'show_variables';
my $sql = "SHOW /*!40103 GLOBAL*/ VARIABLES";
PTDEBUG && _d($dbh, $sql);
my $rows = $dbh->selectall_arrayref($sql);
$config_data{vars} = { map { @$_ } @$rows };
$config_data{mysql_version} = _get_version($dbh);
}
else {
die "Unknown config source";
}
handle_special_vars(\%config_data);
return %config_data;
}
sub handle_special_vars {
my ($config_data) = @_;
if ( $config_data->{vars}->{wsrep_provider_options} ) {
my $vars = $config_data->{vars};
my $dupes = $config_data->{duplicate_vars};
for my $wpo ( $vars->{wsrep_provider_options}, @{$dupes->{wsrep_provider_options} || [] } ) {
my %opts = $wpo =~ /(\S+)\s*=\s*(\S*)(?:;|;?$)/g;
while ( my ($var, $val) = each %opts ) {
$val =~ s/;$//;
if ( exists $vars->{$var} ) {
push @{$dupes->{$var} ||= []}, $val;
}
$vars->{$var} = $val;
}
}
delete $vars->{wsrep_provider_options};
}
return;
}
sub _parse_config_output {
my ( %args ) = @_;
my @required_args = qw(output TextResultSetParser);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
PTDEBUG && _d("Parsing config output");
my $format = $args{format} || detect_config_output_format(%args);
if ( !$format ) {
die "Cannot auto-detect the MySQL config format";
}
my $vars; # variables hashref
my $dupes; # duplicate vars hashref
my $opt_files; # option files arrayref
if ( $format eq 'show_variables' ) {
$vars = parse_show_variables(%args);
}
elsif ( $format eq 'mysqld' ) {
($vars, $opt_files) = parse_mysqld(%args);
}
elsif ( $format eq 'my_print_defaults' ) {
($vars, $dupes) = parse_my_print_defaults(%args);
}
elsif ( $format eq 'option_file' ) {
($vars, $dupes) = parse_option_file(%args);
}
else {
die "Invalid MySQL config format: $format";
}
die "Failed to parse MySQL config" unless $vars && keys %$vars;
if ( $format ne 'show_variables' ) {
_mimic_show_variables(
%args,
format => $format,
vars => $vars,
);
}
return (
format => $format,
vars => $vars,
option_files => $opt_files,
duplicate_vars => $dupes,
);
}
sub detect_config_output_format {
my ( %args ) = @_;
my @required_args = qw(output);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
my $format;
if ( $output =~ m/\|\s+\w+\s+\|\s+.+?\|/
|| $output =~ m/\*+ \d/
|| $output =~ m/Variable_name:\s+\w+/
|| $output =~ m/Variable_name\s+Value$/m )
{
PTDEBUG && _d('show variables format');
$format = 'show_variables';
}
elsif ( $output =~ m/Starts the MySQL database server/
|| $output =~ m/Default options are read from /
|| $output =~ m/^help\s+TRUE /m )
{
PTDEBUG && _d('mysqld format');
$format = 'mysqld';
}
elsif ( $output =~ m/^--\w+/m ) {
PTDEBUG && _d('my_print_defaults format');
$format = 'my_print_defaults';
}
elsif ( $output =~ m/^\s*\[[a-zA-Z]+\]\s*$/m ) {
PTDEBUG && _d('option file format');
$format = 'option_file',
}
return $format;
}
sub parse_show_variables {
my ( %args ) = @_;
my @required_args = qw(output TextResultSetParser);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output, $trp) = @args{@required_args};
my %config = map {
$_->{Variable_name} => $_->{Value}
} @{ $trp->parse($output) };
return \%config;
}
sub parse_mysqld {
my ( %args ) = @_;
my @required_args = qw(output);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
my @opt_files;
if ( $output =~ m/^Default options are read.+\n/mg ) {
my ($opt_files) = $output =~ m/\G^(.+)\n/m;
my %seen;
my @opt_files = grep { !$seen{$_} } split(' ', $opt_files);
PTDEBUG && _d('Option files:', @opt_files);
}
else {
PTDEBUG && _d("mysqld help output doesn't list option files");
}
if ( $output !~ m/^-+ -+$(.+?)(?:\n\n.+)?\z/sm ) {
PTDEBUG && _d("mysqld help output doesn't list vars and vals");
return;
}
my $varvals = $1;
my ($config, undef) = _parse_varvals(
qr/^(\S+)(.*)$/,
$varvals,
);
return $config, \@opt_files;
}
sub parse_my_print_defaults {
my ( %args ) = @_;
my @required_args = qw(output);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
my ($config, $dupes) = _parse_varvals(
qr/^--([^=]+)(?:=(.*))?$/,
$output,
);
return $config, $dupes;
}
sub parse_option_file {
my ( %args ) = @_;
my @required_args = qw(output);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
my ($mysqld_section) = $output =~ m/\[mysqld\](.+?)(?:^\s*\[\w+\]|\Z)/xms;
die "Failed to parse the [mysqld] section" unless $mysqld_section;
my ($config, $dupes) = _parse_varvals(
qr/^([^=]+)(?:=(.*))?$/,
$mysqld_section,
);
return $config, $dupes;
}
sub _preprocess_varvals {
my ($re, $to_parse) = @_;
my %vars;
LINE:
foreach my $line ( split /\n/, $to_parse ) {
next LINE if $line =~ m/^\s*$/; # no empty lines
next LINE if $line =~ /^\s*[#;]/; # no # or ; comment lines
if ( $line !~ $re ) {
PTDEBUG && _d("Line <", $line, "> didn't match $re");
next LINE;
}
my ($var, $val) = ($1, $2);
$var =~ tr/-/_/;
$var =~ s/\s*#.*$//;
if ( !defined $val ) {
$val = '';
}
for my $item ($var, $val) {
$item =~ s/^\s+//;
$item =~ s/\s+$//;
}
push @{$vars{$var} ||= []}, $val
}
return \%vars;
}
sub _parse_varvals {
my ( $vars ) = _preprocess_varvals(@_);
my %config;
my %duplicates;
while ( my ($var, $vals) = each %$vars ) {
my $val = _process_val( pop @$vals );
if ( @$vals && !$can_be_duplicate{$var} ) {
PTDEBUG && _d("Duplicate var:", $var);
foreach my $current_val ( map { _process_val($_) } @$vals ) {
push @{$duplicates{$var} ||= []}, $current_val;
}
}
PTDEBUG && _d("Var:", $var, "val:", $val);
$config{$var} = $val;
}
return \%config, \%duplicates;
}
my $quote_re = qr/
\A # Start of value
(['"]) # Opening quote
(.*) # Value
\1 # Closing quote
\s*(?:\#.*)? # End of line comment
[\n\r]*\z # End of value
/x;
sub _process_val {
my ($val) = @_;
if ( $val =~ $quote_re ) {
$val = $2;
}
else {
$val =~ s/\s*#.*//;
}
if ( my ($num, $factor) = $val =~ m/(\d+)([KMGT])b?$/i ) {
my %factor_for = (
k => 1_024,
m => 1_048_576,
g => 1_073_741_824,
t => 1_099_511_627_776,
);
$val = $num * $factor_for{lc $factor};
}
elsif ( $val =~ m/No default/ ) {
$val = '';
}
return $val;
}
sub _mimic_show_variables {
my ( %args ) = @_;
my @required_args = qw(vars format);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($vars, $format) = @args{@required_args};
foreach my $var ( keys %$vars ) {
if ( $vars->{$var} eq '' ) {
if ( $format eq 'mysqld' ) {
if ( $var ne 'log_error' && $var =~ m/^(?:log|skip|ignore)/ ) {
$vars->{$var} = 'OFF';
}
}
else {
$vars->{$var} = 'ON';
}
}
}
return;
}
sub _slurp_file {
my ( $file ) = @_;
die "I need a file argument" unless $file;
PTDEBUG && _d("Reading", $file);
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
return $contents;
}
sub _get_version {
my ( $dbh ) = @_;
return unless $dbh;
my $version = $dbh->selectrow_arrayref('SELECT VERSION()')->[0];
$version =~ s/(\d\.\d{1,2}.\d{1,2})/$1/;
PTDEBUG && _d('MySQL version', $version);
return $version;
}
sub has {
my ( $self, $var ) = @_;
return exists $self->{vars}->{$var};
}
sub value_of {
my ( $self, $var ) = @_;
return unless $var;
return $self->{vars}->{$var};
}
sub variables {
my ( $self, %args ) = @_;
return $self->{vars};
}
sub duplicate_variables {
my ( $self ) = @_;
return $self->{duplicate_vars};
}
sub option_files {
my ( $self ) = @_;
return $self->{option_files};
}
sub mysql_version {
my ( $self ) = @_;
return $self->{mysql_version};
}
sub format {
my ( $self ) = @_;
return $self->{format};
}
sub is_active {
my ( $self ) = @_;
return $self->{dbh} ? 1 : 0;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MySQLConfig package
# ###########################################################################
# ###########################################################################
# MySQLConfigComparer package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MySQLConfigComparer.pm
# t/lib/MySQLConfigComparer.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MySQLConfigComparer;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
my %alt_val_for = (
ON => 1,
YES => 1,
TRUE => 1,
OFF => 0,
NO => 0,
FALSE => 0,
);
sub new {
my ( $class, %args ) = @_;
my %ignore_vars = (
date_format => 1,
datetime_format => 1,
ft_stopword_file => 1,
timestamp => 1,
time_format => 1,
($args{ignore_variables}
? map { $_ => 1 } @{$args{ignore_variables}}
: ()),
);
my %is_numeric = (
long_query_time => 1,
($args{numeric_variables}
? map { $_ => 1 } @{$args{numeric_variables}}
: ()),
);
my %value_is_optional = (
log_error => 1,
log_isam => 1,
($args{optional_value_variables}
? map { $_ => 1 } @{$args{optional_value_variables}}
: ()),
);
my %any_value_is_true = (
log => 1,
log_bin => 1,
log_slow_queries => 1,
($args{any_value_is_true_variables}
? map { $_ => 1 } @{$args{any_value_is_true_variables}}
: ()),
);
my %base_path = (
character_sets_dir => 'basedir',
datadir => 'basedir',
general_log_file => 'datadir',
language => 'basedir',
log_error => 'datadir',
pid_file => 'datadir',
plugin_dir => 'basedir',
slow_query_log_file => 'datadir',
socket => 'datadir',
($args{base_paths}
? map { $_ => 1 } @{$args{base_paths}}
: ()),
);
my $self = {
ignore_vars => \%ignore_vars,
is_numeric => \%is_numeric,
value_is_optional => \%value_is_optional,
any_value_is_true => \%any_value_is_true,
base_path => \%base_path,
ignore_case => exists $args{ignore_case}
? $args{ignore_case}
: 1,
};
return bless $self, $class;
}
sub diff {
my ( $self, %args ) = @_;
my @required_args = qw(configs);
foreach my $arg( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($configs) = @args{@required_args};
if ( @$configs < 2 ) {
PTDEBUG && _d("Less than two MySQLConfig objects; nothing to compare");
return;
}
my $base_path = $self->{base_path};
my $is_numeric = $self->{is_numeric};
my $any_value_is_true = $self->{any_value_is_true};
my $value_is_optional = $self->{value_is_optional};
my $config0 = $configs->[0];
my $last_config = @$configs - 1;
my $vars = $self->_get_shared_vars(%args);
my $ignore_case = $self->{ignore_case};
my $diffs;
VARIABLE:
foreach my $var ( @$vars ) {
my $is_dir = $var =~ m/dir$/ || $var eq 'language';
my $val0 = $self->_normalize_value( # config0 value
value => $config0->value_of($var),
is_directory => $is_dir,
base_path => $config0->value_of($base_path->{$var}) || "",
);
eval {
CONFIG:
foreach my $configN ( @$configs[1..$last_config] ) {
my $valN = $self->_normalize_value( # configN value
value => $configN->value_of($var),
is_directory => $is_dir,
base_path => $configN->value_of($base_path->{$var}) || "",
);
if ( $is_numeric->{$var} ) {
next CONFIG if $val0 == $valN;
}
else {
next CONFIG if $ignore_case
? lc($val0) eq lc($valN)
: $val0 eq $valN;
if ( $config0->format() ne $configN->format() ) {
if ( $any_value_is_true->{$var} ) {
next CONFIG if $val0 && $valN;
}
if ( $value_is_optional->{$var} ) {
next CONFIG if (!$val0 && $valN) || ($val0 && !$valN);
}
}
}
PTDEBUG && _d("Different", $var, "values:", $val0, $valN);
$diffs->{$var} = [ map { $_->value_of($var) } @$configs ];
last CONFIG;
} # CONFIG
};
if ( $EVAL_ERROR ) {
my $vals = join(', ',
map {
my $val = $_->value_of($var);
defined $val ? $val : 'undef'
} @$configs);
warn "Comparing $var values ($vals) caused an error: $EVAL_ERROR";
}
} # VARIABLE
return $diffs;
}
sub missing {
my ( $self, %args ) = @_;
my @required_args = qw(configs);
foreach my $arg( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($configs) = @args{@required_args};
if ( @$configs < 2 ) {
PTDEBUG && _d("Less than two MySQLConfig objects; nothing to compare");
return;
}
my %vars = map { $_ => 1 } map { keys %{$_->variables()} } @$configs;
my $missing;
foreach my $var ( keys %vars ) {
my $n_configs_having_var = grep { $_->has($var) } @$configs;
if ( $n_configs_having_var < @$configs ) {
$missing->{$var} = [ map { $_->has($var) ? 1 : 0 } @$configs ];
}
}
return $missing;
}
sub _normalize_value {
my ( $self, %args ) = @_;
my ($val, $is_dir, $base_path) = @args{qw(value is_directory base_path)};
$val = defined $val ? $val : '';
$val = $alt_val_for{$val} if exists $alt_val_for{$val};
if ( $val ) {
if ( $is_dir ) {
$val .= '/' unless $val =~ m/\/$/;
}
if ( $base_path && $val !~ m/^\// ) {
$val =~ s/^\.?(.+)/$base_path\/$1/; # prepend base path
$val =~ s/\/{2,}/\//g; # make redundant // single /
}
}
return $val;
}
sub _get_shared_vars {
my ( $self, %args ) = @_;
my ($configs) = @args{qw(configs)};
my $ignore_vars = $self->{ignore_vars};
my $config0 = $configs->[0];
my $last_config = @$configs - 1;
my @vars
= grep { !$ignore_vars->{$_} }
map {
my $config = $_;
my $vars = $config->variables();
grep { $config0->has($_); } keys %$vars;
} @$configs[1..$last_config];
return \@vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MySQLConfigComparer package
# ###########################################################################
# ###########################################################################
# ReportFormatter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/ReportFormatter.pm
# t/lib/ReportFormatter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package ReportFormatter;
use Lmo;
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use List::Util qw(min max);
use POSIX qw(ceil);
eval { require Term::ReadKey };
my $have_term = $EVAL_ERROR ? 0 : 1;
has underline_header => (
is => 'ro',
isa => 'Bool',
default => sub { 1 },
);
has line_prefix => (
is => 'ro',
isa => 'Str',
default => sub { '# ' },
);
has line_width => (
is => 'ro',
isa => 'Int',
default => sub { 78 },
);
has column_spacing => (
is => 'ro',
isa => 'Str',
default => sub { ' ' },
);
has extend_right => (
is => 'ro',
isa => 'Bool',
default => sub { '' },
);
has truncate_line_mark => (
is => 'ro',
isa => 'Str',
default => sub { '...' },
);
has column_errors => (
is => 'ro',
isa => 'Str',
default => sub { 'warn' },
);
has truncate_header_side => (
is => 'ro',
isa => 'Str',
default => sub { 'left' },
);
has strip_whitespace => (
is => 'ro',
isa => 'Bool',
default => sub { 1 },
);
has title => (
is => 'rw',
isa => 'Str',
predicate => 'has_title',
);
has n_cols => (
is => 'rw',
isa => 'Int',
default => sub { 0 },
init_arg => undef,
);
has cols => (
is => 'ro',
isa => 'ArrayRef',
init_arg => undef,
default => sub { [] },
clearer => 'clear_cols',
);
has lines => (
is => 'ro',
isa => 'ArrayRef',
init_arg => undef,
default => sub { [] },
clearer => 'clear_lines',
);
has truncate_headers => (
is => 'rw',
isa => 'Bool',
default => sub { undef },
init_arg => undef,
clearer => 'clear_truncate_headers',
);
sub BUILDARGS {
my $class = shift;
my $args = $class->SUPER::BUILDARGS(@_);
if ( ($args->{line_width} || '') eq 'auto' ) {
die "Cannot auto-detect line width because the Term::ReadKey module "
. "is not installed" unless $have_term;
($args->{line_width}) = GetTerminalSize();
PTDEBUG && _d('Line width:', $args->{line_width});
}
return $args;
}
sub set_columns {
my ( $self, @cols ) = @_;
my $min_hdr_wid = 0; # check that header fits on line
my $used_width = 0;
my @auto_width_cols;
for my $i ( 0..$#cols ) {
my $col = $cols[$i];
my $col_name = $col->{name};
my $col_len = length $col_name;
die "Column does not have a name" unless defined $col_name;
if ( $col->{width} ) {
$col->{width_pct} = ceil(($col->{width} * 100) / $self->line_width());
PTDEBUG && _d('col:', $col_name, 'width:', $col->{width}, 'chars =',
$col->{width_pct}, '%');
}
if ( $col->{width_pct} ) {
$used_width += $col->{width_pct};
}
else {
PTDEBUG && _d('Auto width col:', $col_name);
$col->{auto_width} = 1;
push @auto_width_cols, $i;
}
$col->{truncate} = 1 unless defined $col->{truncate};
$col->{truncate_mark} = '...' unless defined $col->{truncate_mark};
$col->{truncate_side} ||= 'right';
$col->{undef_value} = '' unless defined $col->{undef_value};
$col->{min_val} = 0;
$col->{max_val} = 0;
$min_hdr_wid += $col_len;
$col->{header_width} = $col_len;
$col->{right_most} = 1 if $i == $#cols;
push @{$self->cols}, $col;
}
$self->n_cols( scalar @cols );
if ( ($used_width || 0) > 100 ) {
die "Total width_pct for all columns is >100%";
}
if ( @auto_width_cols ) {
my $wid_per_col = int((100 - $used_width) / scalar @auto_width_cols);
PTDEBUG && _d('Line width left:', (100-$used_width), '%;',
'each auto width col:', $wid_per_col, '%');
map { $self->cols->[$_]->{width_pct} = $wid_per_col } @auto_width_cols;
}
$min_hdr_wid += ($self->n_cols() - 1) * length $self->column_spacing();
PTDEBUG && _d('min header width:', $min_hdr_wid);
if ( $min_hdr_wid > $self->line_width() ) {
PTDEBUG && _d('Will truncate headers because min header width',
$min_hdr_wid, '> line width', $self->line_width());
$self->truncate_headers(1);
}
return;
}
sub add_line {
my ( $self, @vals ) = @_;
my $n_vals = scalar @vals;
if ( $n_vals != $self->n_cols() ) {
$self->_column_error("Number of values $n_vals does not match "
. "number of columns " . $self->n_cols());
}
for my $i ( 0..($n_vals-1) ) {
my $col = $self->cols->[$i];
my $val = defined $vals[$i] ? $vals[$i] : $col->{undef_value};
if ( $self->strip_whitespace() ) {
$val =~ s/^\s+//g;
$val =~ s/\s+$//;
$vals[$i] = $val;
}
my $width = length $val;
$col->{min_val} = min($width, ($col->{min_val} || $width));
$col->{max_val} = max($width, ($col->{max_val} || $width));
}
push @{$self->lines}, \@vals;
return;
}
sub get_report {
my ( $self, %args ) = @_;
$self->_calculate_column_widths();
if ( $self->truncate_headers() ) {
$self->_truncate_headers();
}
$self->_truncate_line_values(%args);
my @col_fmts = $self->_make_column_formats();
my $fmt = $self->line_prefix()
. join($self->column_spacing(), @col_fmts);
PTDEBUG && _d('Format:', $fmt);
(my $hdr_fmt = $fmt) =~ s/%([^-])/%-$1/g;
my @lines;
push @lines, $self->line_prefix() . $self->title() if $self->has_title();
push @lines, $self->_truncate_line(
sprintf($hdr_fmt, map { $_->{name} } @{$self->cols}),
strip => 1,
mark => '',
);
if ( $self->underline_header() ) {
my @underlines = map { '=' x $_->{print_width} } @{$self->cols};
push @lines, $self->_truncate_line(
sprintf($fmt, map { $_ || '' } @underlines),
mark => '',
);
}
push @lines, map {
my $vals = $_;
my $i = 0;
my @vals = map {
my $val = defined $_ ? $_ : $self->cols->[$i++]->{undef_value};
$val = '' if !defined $val;
$val =~ s/\n/ /g;
$val;
} @$vals;
my $line = sprintf($fmt, @vals);
if ( $self->extend_right() ) {
$line;
}
else {
$self->_truncate_line($line);
}
} @{$self->lines};
$self->clear_cols();
$self->clear_lines();
$self->clear_truncate_headers();
return join("\n", @lines) . "\n";
}
sub truncate_value {
my ( $self, $col, $val, $width, $side ) = @_;
return $val if length $val <= $width;
return $val if $col->{right_most} && $self->extend_right();
$side ||= $col->{truncate_side};
my $mark = $col->{truncate_mark};
if ( $side eq 'right' ) {
$val = substr($val, 0, $width - length $mark);
$val .= $mark;
}
elsif ( $side eq 'left') {
$val = $mark . substr($val, -1 * $width + length $mark);
}
else {
PTDEBUG && _d("I don't know how to", $side, "truncate values");
}
return $val;
}
sub _calculate_column_widths {
my ( $self ) = @_;
my $extra_space = 0;
foreach my $col ( @{$self->cols} ) {
my $print_width = int($self->line_width() * ($col->{width_pct} / 100));
PTDEBUG && _d('col:', $col->{name}, 'width pct:', $col->{width_pct},
'char width:', $print_width,
'min val:', $col->{min_val}, 'max val:', $col->{max_val});
if ( $col->{auto_width} ) {
if ( $col->{min_val} && $print_width < $col->{min_val} ) {
PTDEBUG && _d('Increased to min val width:', $col->{min_val});
$print_width = $col->{min_val};
}
elsif ( $col->{max_val} && $print_width > $col->{max_val} ) {
PTDEBUG && _d('Reduced to max val width:', $col->{max_val});
$extra_space += $print_width - $col->{max_val};
$print_width = $col->{max_val};
}
}
$col->{print_width} = $print_width;
PTDEBUG && _d('print width:', $col->{print_width});
}
PTDEBUG && _d('Extra space:', $extra_space);
while ( $extra_space-- ) {
foreach my $col ( @{$self->cols} ) {
if ( $col->{auto_width}
&& ( $col->{print_width} < $col->{max_val}
|| $col->{print_width} < $col->{header_width})
) {
$col->{print_width}++;
}
}
}
return;
}
sub _truncate_headers {
my ( $self, $col ) = @_;
my $side = $self->truncate_header_side();
foreach my $col ( @{$self->cols} ) {
my $col_name = $col->{name};
my $print_width = $col->{print_width};
next if length $col_name <= $print_width;
$col->{name} = $self->truncate_value($col, $col_name, $print_width, $side);
PTDEBUG && _d('Truncated hdr', $col_name, 'to', $col->{name},
'max width:', $print_width);
}
return;
}
sub _truncate_line_values {
my ( $self, %args ) = @_;
my $n_vals = $self->n_cols() - 1;
foreach my $vals ( @{$self->lines} ) {
for my $i ( 0..$n_vals ) {
my $col = $self->cols->[$i];
my $val = defined $vals->[$i] ? $vals->[$i] : $col->{undef_value};
my $width = length $val;
if ( $col->{print_width} && $width > $col->{print_width} ) {
if ( !$col->{truncate} ) {
$self->_column_error("Value '$val' is too wide for column "
. $col->{name});
}
my $callback = $args{truncate_callback};
my $print_width = $col->{print_width};
$val = $callback ? $callback->($col, $val, $print_width)
: $self->truncate_value($col, $val, $print_width);
PTDEBUG && _d('Truncated val', $vals->[$i], 'to', $val,
'; max width:', $print_width);
$vals->[$i] = $val;
}
}
}
return;
}
sub _make_column_formats {
my ( $self ) = @_;
my @col_fmts;
my $n_cols = $self->n_cols() - 1;
for my $i ( 0..$n_cols ) {
my $col = $self->cols->[$i];
my $width = $col->{right_most} && !$col->{right_justify} ? ''
: $col->{print_width};
my $col_fmt = '%' . ($col->{right_justify} ? '' : '-') . $width . 's';
push @col_fmts, $col_fmt;
}
return @col_fmts;
}
sub _truncate_line {
my ( $self, $line, %args ) = @_;
my $mark = defined $args{mark} ? $args{mark} : $self->truncate_line_mark();
if ( $line ) {
$line =~ s/\s+$// if $args{strip};
my $len = length($line);
if ( $len > $self->line_width() ) {
$line = substr($line, 0, $self->line_width() - length $mark);
$line .= $mark if $mark;
}
}
return $line;
}
sub _column_error {
my ( $self, $err ) = @_;
my $msg = "Column error: $err";
$self->column_errors() eq 'die' ? die $msg : warn $msg;
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
no Lmo;
1;
}
# ###########################################################################
# End ReportFormatter package
# ###########################################################################
# ###########################################################################
# HTTP::Micro package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/HTTP/Micro.pm
# t/lib/HTTP/Micro.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package HTTP::Micro;
our $VERSION = '0.01';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent timeout);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $agent = $class) =~ s{::}{-}g;
my $self = {
agent => $agent . "/" . ($class->VERSION || 0),
timeout => 60,
};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
return bless $self, $class;
}
my %DefaultPort = (
http => 80,
https => 443,
);
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
$args ||= {}; # we keep some state in this during _request
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $method eq 'GET'
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
$handle->connect($scheme, $host, $port);
$self->_prepare_headers_and_cb($request, $args);
$handle->write_request_header(@{$request}{qw/method uri headers/});
$handle->write_content_body($request) if $request->{content};
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
$response->{content} = '';
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args) = @_;
for ($args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if (defined $args->{content}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
utf8::downgrade($args->{content}, 1)
or Carp::croak(q/Wide character in request message body/);
$request->{headers}{'content-length'} = length $args->{content};
$request->{content} = $args->{content};
}
return;
}
sub _split_url {
my $url = pop;
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or Carp::croak(qq/Cannot parse URL: '$url'/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: $DefaultPort{$scheme}
};
return ($scheme, $host, $port, $path_query);
}
} # HTTP::Micro
{
package HTTP::Micro::Handle;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp qw(croak);
use Errno qw(EINTR EPIPE);
use IO::Socket qw(SOCK_STREAM);
sub BUFSIZE () { 32768 }
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
my $ssl_verify_args = {
check_cn => "when_only",
wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere"
};
sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
eval "require IO::Socket::SSL"
unless exists $INC{'IO/Socket/SSL.pm'};
croak(qq/IO::Socket::SSL must be installed for https support\n/)
unless $INC{'IO/Socket/SSL.pm'};
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = IO::Socket::INET->new(
PeerHost => $host,
PeerPort => $port,
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh})
or croak(qq/Could not binmode() socket: '$!'/);
if ( $scheme eq 'https') {
IO::Socket::SSL->start_SSL($self->{fh});
ref($self->{fh}) eq 'IO::Socket::SSL'
or die(qq/SSL connection failed for $host\n/);
if ( $self->{fh}->can("verify_hostname") ) {
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
or die(qq/SSL certificate not valid for $host\n/);
}
else {
my $fh = $self->{fh};
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
or die(qq/SSL certificate not valid for $host\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_;
CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/);
}
sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_;
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or croak(q/Timed out while waiting for socket to become ready for writing/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
croak(qq/Socket closed by remote server: $!/);
}
elsif ($! != EINTR) {
croak(qq/Could not write to socket: '$!'/);
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
if ($len) {
croak(q/Unexpected end of stream/);
}
return $buf;
}
sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
croak(q/Unexpected end of stream while looking for line/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
$val = \($headers->{$field_name} = $2);
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or croak(q/Unexpected header continuation line/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
$field_name =~ s/\b(\w)/\u$1/g;
$buf .= "$field_name: $v\x0D\x0A";
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_content_body {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $len) = @_;
$len ||= $response->{headers}{'content-length'};
croak("No content-length in the returned response, and this "
. "UA doesn't implement chunking") unless defined $len;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read), $response);
$len -= $read;
}
return;
}
sub write_content_body {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
$len += $self->write($request->{content});
$len == $content_length
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len;
}
sub read_response_header {
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or croak(q/Malformed Status-Line: / . $Printable->($line));
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or croak(q/select(2): 'Bad file descriptor'/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or croak(qq/select(2): '$!'/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift;
return $self->_do_timeout('write', @_)
}
} # HTTP::Micro::Handle
my $prog = <<'EOP';
BEGIN {
if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
*CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
}
else {
constant->import( CAN_IPV6 => '' );
}
my %const = (
NID_CommonName => 13,
GEN_DNS => 2,
GEN_IPADD => 7,
);
while ( my ($name,$value) = each %const ) {
no strict 'refs';
*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
}
}
{
use Carp qw(croak);
my %dispatcher = (
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
);
if ( $Net::SSLeay::VERSION >= 1.30 ) {
$dispatcher{commonName} = sub {
my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
$cn;
}
} else {
$dispatcher{commonName} = sub {
croak "you need at least Net::SSLeay version 1.30 for getting commonName"
}
}
if ( $Net::SSLeay::VERSION >= 1.33 ) {
$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
} else {
$dispatcher{subjectAltNames} = sub {
return;
};
}
$dispatcher{authority} = $dispatcher{issuer};
$dispatcher{owner} = $dispatcher{subject};
$dispatcher{cn} = $dispatcher{commonName};
sub _peer_certificate {
my ($self, $field) = @_;
my $ssl = $self->_get_ssl_object or return;
my $cert = ${*$self}{_SSL_certificate}
||= Net::SSLeay::get_peer_certificate($ssl)
or return $self->error("Could not retrieve peer certificate");
if ($field) {
my $sub = $dispatcher{$field} or croak
"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
"\nMaybe you need to upgrade your Net::SSLeay";
return $sub->($cert);
} else {
return $cert
}
}
my %scheme = (
ldap => {
wildcards_in_cn => 0,
wildcards_in_alt => 'leftmost',
check_cn => 'always',
},
http => {
wildcards_in_cn => 'anywhere',
wildcards_in_alt => 'anywhere',
check_cn => 'when_only',
},
smtp => {
wildcards_in_cn => 0,
wildcards_in_alt => 0,
check_cn => 'always'
},
none => {}, # do not check
);
$scheme{www} = $scheme{http}; # alias
$scheme{xmpp} = $scheme{http}; # rfc 3920
$scheme{pop3} = $scheme{ldap}; # rfc 2595
$scheme{imap} = $scheme{ldap}; # rfc 2595
$scheme{acap} = $scheme{ldap}; # rfc 2595
$scheme{nntp} = $scheme{ldap}; # rfc 4642
$scheme{ftp} = $scheme{http}; # rfc 4217
sub _verify_hostname_of_cert {
my $identity = shift;
my $cert = shift;
my $scheme = shift || 'none';
if ( ! ref($scheme) ) {
$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
}
return 1 if ! %$scheme; # 'none'
my $commonName = $dispatcher{cn}->($cert);
my @altNames = $dispatcher{subjectAltNames}->($cert);
if ( my $sub = $scheme->{callback} ) {
return $sub->($identity,$commonName,@altNames);
}
my $ipn;
if ( CAN_IPV6 and $identity =~m{:} ) {
$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
} else {
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
$identity =~m{\0} and croak("name '$identity' has \\0 byte");
$identity = IO::Socket::SSL::idn_to_ascii($identity) or
croak "Warning: Given name '$identity' could not be converted to IDNA!";
}
}
my $check_name = sub {
my ($name,$identity,$wtyp) = @_;
$wtyp ||= '';
my $pattern;
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
} else {
$pattern = qr{^\Q$name\E$}i;
}
return $identity =~ $pattern;
};
my $alt_dnsNames = 0;
while (@altNames) {
my ($type, $name) = splice (@altNames, 0, 2);
if ( $ipn and $type == GEN_IPADD ) {
return 1 if $ipn eq $name;
} elsif ( ! $ipn and $type == GEN_DNS ) {
$name =~s/\s+$//; $name =~s/^\s+//;
$alt_dnsNames++;
$check_name->($name,$identity,$scheme->{wildcards_in_alt})
and return 1;
}
}
if ( ! $ipn and (
$scheme->{check_cn} eq 'always' or
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
and return 1;
}
return 0; # no match
}
}
EOP
eval { require IO::Socket::SSL };
if ( $INC{"IO/Socket/SSL.pm"} ) {
eval $prog;
die $@ if $@;
}
1;
# ###########################################################################
# End HTTP::Micro package
# ###########################################################################
# ###########################################################################
# VersionCheck package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionCheck.pm
# t/lib/VersionCheck.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionCheck;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
use Digest::MD5 qw(md5_hex);
use Sys::Hostname qw(hostname);
use File::Basename qw();
use File::Spec;
use FindBin qw();
eval {
require Percona::Toolkit;
require HTTP::Micro;
};
{
my $file = 'percona-version-check';
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my @vc_dirs = (
'/etc/percona',
'/etc/percona-toolkit',
'/tmp',
"$home",
);
sub version_check_file {
foreach my $dir ( @vc_dirs ) {
if ( -d $dir && -w $dir ) {
PTDEBUG && _d('Version check file', $file, 'in', $dir);
return $dir . '/' . $file;
}
}
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
return $file; # in the CWD
}
}
sub version_check_time_limit {
return 60 * 60 * 24; # one day
}
sub version_check {
my (%args) = @_;
my $instances = $args{instances} || [];
my $instances_to_check;
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
if ( !$args{force} ) {
if ( $FindBin::Bin
&& (-d "$FindBin::Bin/../.bzr" ||
-d "$FindBin::Bin/../../.bzr" ||
-d "$FindBin::Bin/../.git" ||
-d "$FindBin::Bin/../../.git"
)
) {
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
return;
}
}
eval {
foreach my $instance ( @$instances ) {
my ($name, $id) = get_instance_id($instance);
$instance->{name} = $name;
$instance->{id} = $id;
}
push @$instances, { name => 'system', id => 0 };
$instances_to_check = get_instances_to_check(
instances => $instances,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
return unless @$instances_to_check;
my $protocol = 'https';
eval { require IO::Socket::SSL; };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
PTDEBUG && _d("SSL not available, won't run version_check");
return;
}
PTDEBUG && _d('Using', $protocol);
my $advice = pingback(
instances => $instances_to_check,
protocol => $protocol,
url => $args{url} # testing
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
|| "$protocol://v.percona.com",
);
if ( $advice ) {
PTDEBUG && _d('Advice:', Dumper($advice));
if ( scalar @$advice > 1) {
print "\n# " . scalar @$advice . " software updates are "
. "available:\n";
}
else {
print "\n# A software update is available:\n";
}
print join("\n", map { "# * $_" } @$advice), "\n\n";
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
}
if ( @$instances_to_check ) {
eval {
update_check_times(
instances => $instances_to_check,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
}
}
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
warn "Exiting because the PTDEBUG_VERSION_CHECK "
. "environment variable is defined.\n";
exit 255;
}
return;
}
sub get_instances_to_check {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
if ( !-f $vc_file ) {
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
'version checking all instances');
return $instances;
}
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
chomp(my $file_contents = do { local $/ = undef; <$fh> });
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
close $fh;
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
my $check_time_limit = version_check_time_limit();
my @instances_to_check;
foreach my $instance ( @$instances ) {
my $last_check_time = $last_check_time_for{ $instance->{id} };
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
'hours until next check',
sprintf '%.2f',
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
if ( !defined $last_check_time
|| ($now - $last_check_time) >= $check_time_limit ) {
PTDEBUG && _d('Time to check', Dumper($instance));
push @instances_to_check, $instance;
}
}
return \@instances_to_check;
}
sub update_check_times {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
PTDEBUG && _d('Updating last check time:', $now);
my %all_instances = map {
$_->{id} => { name => $_->{name}, ts => $now }
} @$instances;
if ( -f $vc_file ) {
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
foreach my $line ( split("\n", ($contents || '')) ) {
my ($id, $ts) = split(',', $line);
if ( !exists $all_instances{$id} ) {
$all_instances{$id} = { ts => $ts }; # original ts, not updated
}
}
}
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
foreach my $id ( sort keys %all_instances ) {
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
}
close $fh;
return;
}
sub get_instance_id {
my ($instance) = @_;
my $dbh = $instance->{dbh};
my $dsn = $instance->{dsn};
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
PTDEBUG && _d($sql);
my ($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$sql = q{SELECT @@hostname};
PTDEBUG && _d($sql);
($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
}
else {
$sql = q{SHOW VARIABLES LIKE 'port'};
PTDEBUG && _d($sql);
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
PTDEBUG && _d('port:', $port);
$name .= $port || '';
}
}
my $id = md5_hex($name);
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
return $name, $id;
}
sub pingback {
my (%args) = @_;
my @required_args = qw(url instances);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my $url = $args{url};
my $instances = $args{instances};
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
my $response = $ua->request('GET', $url);
PTDEBUG && _d('Server response:', Dumper($response));
die "No response from GET $url"
if !$response;
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
($response->{content} || '')) if $response->{status} != 200;
die("GET on $url did not return any programs to check")
if !$response->{content};
my $items = parse_server_response(
response => $response->{content}
);
die "Failed to parse server requested programs: $response->{content}"
if !scalar keys %$items;
my $versions = get_versions(
items => $items,
instances => $instances,
);
die "Failed to get any program versions; should have at least gotten Perl"
if !scalar keys %$versions;
my $client_content = encode_client_response(
items => $items,
versions => $versions,
general_id => md5_hex( hostname() ),
);
my $client_response = {
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
content => $client_content,
};
PTDEBUG && _d('Client response:', Dumper($client_response));
$response = $ua->request('POST', $url, $client_response);
PTDEBUG && _d('Server suggestions:', Dumper($response));
die "No response from POST $url $client_response"
if !$response;
die "POST $url returned HTTP status $response->{status}; expected 200"
if $response->{status} != 200;
return unless $response->{content};
$items = parse_server_response(
response => $response->{content},
split_vars => 0,
);
die "Failed to parse server suggestions: $response->{content}"
if !scalar keys %$items;
my @suggestions = map { $_->{vars} }
sort { $a->{item} cmp $b->{item} }
values %$items;
return \@suggestions;
}
sub encode_client_response {
my (%args) = @_;
my @required_args = qw(items versions general_id);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items, $versions, $general_id) = @args{@required_args};
my @lines;
foreach my $item ( sort keys %$items ) {
next unless exists $versions->{$item};
if ( ref($versions->{$item}) eq 'HASH' ) {
my $mysql_versions = $versions->{$item};
for my $id ( sort keys %$mysql_versions ) {
push @lines, join(';', $id, $item, $mysql_versions->{$id});
}
}
else {
push @lines, join(';', $general_id, $item, $versions->{$item});
}
}
my $client_response = join("\n", @lines) . "\n";
return $client_response;
}
sub parse_server_response {
my (%args) = @_;
my @required_args = qw(response);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($response) = @args{@required_args};
my %items = map {
my ($item, $type, $vars) = split(";", $_);
if ( !defined $args{split_vars} || $args{split_vars} ) {
$vars = [ split(",", ($vars || '')) ];
}
$item => {
item => $item,
type => $type,
vars => $vars,
};
} split("\n", $response);
PTDEBUG && _d('Items:', Dumper(\%items));
return \%items;
}
my %sub_for_type = (
os_version => \&get_os_version,
perl_version => \&get_perl_version,
perl_module_version => \&get_perl_module_version,
mysql_variable => \&get_mysql_variable,
);
sub valid_item {
my ($item) = @_;
return unless $item;
if ( !exists $sub_for_type{ $item->{type} } ) {
PTDEBUG && _d('Invalid type:', $item->{type});
return 0;
}
return 1;
}
sub get_versions {
my (%args) = @_;
my @required_args = qw(items);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items) = @args{@required_args};
my %versions;
foreach my $item ( values %$items ) {
next unless valid_item($item);
eval {
my $version = $sub_for_type{ $item->{type} }->(
item => $item,
instances => $args{instances},
);
if ( $version ) {
chomp $version unless ref($version);
$versions{$item->{item}} = $version;
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
}
}
return \%versions;
}
sub get_os_version {
if ( $OSNAME eq 'MSWin32' ) {
require Win32;
return Win32::GetOSDisplayName();
}
chomp(my $platform = `uname -s`);
PTDEBUG && _d('platform:', $platform);
return $OSNAME unless $platform;
chomp(my $lsb_release
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
PTDEBUG && _d('lsb_release:', $lsb_release);
my $release = "";
if ( $platform eq 'Linux' ) {
if ( -f "/etc/fedora-release" ) {
$release = `cat /etc/fedora-release`;
}
elsif ( -f "/etc/redhat-release" ) {
$release = `cat /etc/redhat-release`;
}
elsif ( -f "/etc/system-release" ) {
$release = `cat /etc/system-release`;
}
elsif ( $lsb_release ) {
$release = `$lsb_release -ds`;
}
elsif ( -f "/etc/lsb-release" ) {
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
$release =~ s/^\w+="([^"]+)".+/$1/;
}
elsif ( -f "/etc/debian_version" ) {
chomp(my $rel = `cat /etc/debian_version`);
$release = "Debian $rel";
if ( -f "/etc/apt/sources.list" ) {
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}'`);
$release .= " ($code_name)" if $code_name;
}
}
elsif ( -f "/etc/os-release" ) { # openSUSE
chomp($release = `grep PRETTY_NAME /etc/os-release`);
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
}
elsif ( `ls /etc/*release 2>/dev/null` ) {
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
}
else {
$release = `cat /etc/*release | head -n1`;
}
}
}
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
my $rel = `uname -r`;
$release = "$platform $rel";
}
elsif ( $platform eq "SunOS" ) {
my $rel = `head -n1 /etc/release` || `uname -r`;
$release = "$platform $rel";
}
if ( !$release ) {
PTDEBUG && _d('Failed to get the release, using platform');
$release = $platform;
}
chomp($release);
$release =~ s/^"|"$//g;
PTDEBUG && _d('OS version =', $release);
return $release;
}
sub get_perl_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $version = sprintf '%vd', $PERL_VERSION;
PTDEBUG && _d('Perl version', $version);
return $version;
}
sub get_perl_module_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $var = '$' . $item->{item} . '::VERSION';
my $version = eval "use $item->{item}; $var;";
PTDEBUG && _d('Perl version for', $var, '=', $version);
return $version;
}
sub get_mysql_variable {
return get_from_mysql(
show => 'VARIABLES',
@_,
);
}
sub get_from_mysql {
my (%args) = @_;
my $show = $args{show};
my $item = $args{item};
my $instances = $args{instances};
return unless $show && $item;
if ( !$instances || !@$instances ) {
PTDEBUG && _d('Cannot check', $item,
'because there are no MySQL instances');
return;
}
if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
@{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
}
my @versions;
my %version_for;
foreach my $instance ( @$instances ) {
next unless $instance->{id}; # special system instance has id=0
my $dbh = $instance->{dbh};
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $sql = qq/SHOW $show/;
PTDEBUG && _d($sql);
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
my @versions;
foreach my $var ( @{$item->{vars}} ) {
$var = lc($var);
my $version = $rows->{$var}->{value};
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
'on', $instance->{name});
push @versions, $version;
}
$version_for{ $instance->{id} } = join(' ', @versions);
}
return \%version_for;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End VersionCheck package
# ###########################################################################
# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check at the end of this package for the call to main() which actually runs
# the program.
# ###########################################################################
package pt_config_diff;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
use Percona::Toolkit;
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub main {
local @ARGV = @_; # set global ARGV for this package
# ########################################################################
# Get configuration information.
# ########################################################################
my $o = new OptionParser();
$o->get_specs();
$o->get_opts();
my $dp = $o->DSNParser();
$dp->prop('set-vars', $o->set_vars());
if ( !$o->get('help') ) {
if ( @ARGV < 1 ) {
$o->save_error("Specify at least one file or DSN on the command line");
}
}
$o->usage_or_errors();
# #########################################################################
# Make common modules.
# #########################################################################
my $trp = new TextResultSetParser();
my $config_cmp = new MySQLConfigComparer(
ignore_variables => $o->get('ignore-variables'),
ignore_case => $o->get('ignore-case'),
);
my %common_modules = (
DSNParser => $dp,
OptionParser => $o,
MySQLConfigComparer => $config_cmp,
TextResultSetParser => $trp,
);
# #########################################################################
# Make MySQLConfig objs for each FILE|DSN.
# #########################################################################
my $dsn_defaults = $dp->parse_options($o);
my $last_dsn;
my @configs; # MySQLConfig objects
my @config_names; # Human-readable names for those ^ objs
my @cxn;
foreach my $config_src ( @ARGV ) {
if ( -f $config_src ) {
PTDEBUG && _d('Config source', $config_src, 'is a file');
push @configs, new MySQLConfig(
file => $config_src,
%common_modules,
);
push @config_names, $config_src; # filename
}
else {
PTDEBUG && _d('Config source', $config_src, 'is a DSN');
my $cxn = new Cxn(
dsn_string => $config_src,
prev_dsn => $last_dsn,
DSNParser => $dp,
OptionParser => $o,
);
$cxn->connect();
$last_dsn = $cxn->dsn();
push @configs, new MySQLConfig(
dbh => $cxn->dbh(),
dsn => $cxn->dsn(),
%common_modules,
);
push @config_names, $cxn->name();
push @cxn, $cxn;
}
}
# ########################################################################
# Daemonize now that everything is setup and ready to work.
# ########################################################################
my $daemon;
if ( $o->get('pid') ) {
# We're not daemoninzing, it just handles PID stuff.
$daemon = new Daemon(o=>$o);
$daemon->make_PID_file();
}
# ########################################################################
# Do the version-check
# ########################################################################
if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
VersionCheck::version_check(
force => $o->got('version-check'),
instances => [ map({ +{ dbh => $_->dbh, dsn => $_->dsn } } @cxn) ],
);
}
# #########################################################################
# Diff the given configs.
# #########################################################################
my $report;
my $truncate_callback;
if ( $o->get('report') ) {
$report = new ReportFormatter(
line_prefix => '',
line_width => $o->get('report-width'),
);
$report->set_columns(
{ name => 'Variable', width=>25, },
map { { name => $_ } } @config_names,
);
# This is difficult. Ideally, we want to know which var this
# val applies to (i.e. first column, same row). But that's
# not how ReportFormatter works. Plus, even if we truncate a
# path on the left side, that might be where the difference is.
# So there's no easy solution here.
# $truncate_callback = sub {
# };
}
PTDEBUG && _d("Comparing", scalar @configs, "configs");
my $diffs = $config_cmp->diff(configs=>\@configs);
my $n_diffs = scalar keys %$diffs;
PTDEBUG && _d($n_diffs, "differences found:", Dumper($diffs));
if ( $n_diffs ) {
if ( $o->get('report') ) {
foreach my $var ( sort keys %$diffs ) {
$report->add_line($var, @{$diffs->{$var}});
}
$report->title(
"$n_diffs config difference" . ($n_diffs > 1 ? 's' : ''));
print $report->get_report();
}
return 1;
}
# No differences.
return 0;
}
# ##########################################################################
# Subroutines
# ##########################################################################
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }
1; # Because this is a module as well as a script.
# ############################################################################
# Documentation
# ############################################################################
=pod
=head1 NAME
pt-config-diff - Diff MySQL configuration files and server variables.
=head1 SYNOPSIS
Usage: pt-config-diff [OPTIONS] CONFIG CONFIG [CONFIG...]
pt-config-diff diffs MySQL configuration files and server variables.
CONFIG can be a filename or a DSN. At least two CONFIG sources must be given.
Like standard Unix diff, there is no output if there are no differences.
Diff host1 config from SHOW VARIABLES against host2:
pt-config-diff h=host1 h=host2
Diff config from [mysqld] section in my.cnf against host1 config:
pt-config-diff /etc/my.cnf h=host1
Diff the [mysqld] section of two option files:
pt-config-diff /etc/my-small.cnf /etc/my-large.cnf
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
pt-config-diff diffs MySQL configurations by examining the values of server
system variables from two or more CONFIG sources specified on the command
line. A CONFIG source can be a DSN or a filename containing the output of
C<mysqld --help --verbose>, C<my_print_defaults>, C<SHOW VARIABLES>, or
an option file (e.g. my.cnf).
For each DSN CONFIG, pt-config-diff connects to MySQL and gets variables
and values by executing C<SHOW /*!40103 GLOBAL*/ VARIABLES>. This is
an "active config" because it shows what server values MySQL is
actively (currently) running with.
Only variables that all CONFIG sources have are compared because if a
variable is not present then we cannot know or safely guess its value.
For example, if you compare an option file (e.g. my.cnf) to an active config
(i.e. SHOW VARIABLES from a DSN CONFIG), the option file will probably
only have a few variables, whereas the active config has every variable.
Only values of the variables present in both configs are compared.
Option file and DSN configs provide the best results.
=head1 OUTPUT
There is no output when there are no differences. When there are differences,
pt-config-diff prints a report to STDOUT that looks similar to the following:
2 config differences
Variable my.master.cnf my.slave.cnf
========================= =============== ===============
datadir /tmp/12345/data /tmp/12346/data
port 12345 12346
Comparing MySQL variables is difficult because there are many variations and
subtleties across the many versions and distributions of MySQL. When a
comparison fails, the tool prints a warning to STDERR, such as the following:
Comparing log_error values (mysqld.log, /tmp/12345/data/mysqld.log)
caused an error: Argument "/tmp/12345/data/mysqld.log" isn't numeric
in numeric eq (==) at ./pt-config-diff line 2311.
Please report these warnings so the comparison functions can be improved.
=head1 EXIT STATUS
pt-config-diff exits with a zero exit status when there are no differences, and
1 if there are.
=head1 OPTIONS
This tool accepts additional command-line arguments. Refer to the
L<"SYNOPSIS"> and usage information for details.
=over
=item --ask-pass
Prompt for a password when connecting to MySQL.
=item --charset
short form: -A; type: string
Default character set. If the value is utf8, sets Perl's binmode on
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and
runs SET NAMES UTF8 after connecting to MySQL. Any other value sets
binmode on STDOUT without the utf8 layer, and runs SET NAMES after
connecting to MySQL.
=item --config
type: Array
Read this comma-separated list of config files; if specified, this must be the
first option on the command line. (This option does not specify a CONFIG;
it's equivalent to C<--defaults-file>.)
=item --database
short form: -D; type: string
Connect to this database.
=item --defaults-file
short form: -F; type: string
Only read mysql options from the given file. You must give an absolute
pathname.
=item --help
Show help and exit.
=item --host
short form: -h; type: string
Connect to host.
=item --[no]ignore-case
default: yes
Compare the variables case-insensitively.
=item --ignore-variables
type: array
Ignore, do not compare, these variables.
=item --password
short form: -p; type: string
Password to use for connection.
=item --pid
type: string
Create the given PID file. The tool won't start if the PID file already
exists and the PID it contains is different than the current PID. However,
if the PID file exists and the PID it contains is no longer running, the
tool will overwrite the PID file with the current PID. The PID file is
removed automatically when the tool exits.
=item --port
short form: -P; type: int
Port number to use for connection.
=item --[no]report
default: yes
Print the MySQL config diff report to STDOUT. If you just want to check
if the given configs are different or not by examining the tool's exit
status, then specify C<--no-report> to suppress the report.
=item --report-width
type: int; default: 78
Truncate report lines to this many characters. Since some variable values can
be long, or when comparing multiple configs, it may help to increase the
report width so values are not truncated beyond readability.
=item --set-vars
type: Array
Set the MySQL variables in this comma-separated list of C<variable=value> pairs.
By default, the tool sets:
=for comment ignore-pt-internal-value
MAGIC_set_vars
wait_timeout=10000
Variables specified on the command line override these defaults. For
example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>.
The tool prints a warning and continues if a variable cannot be set.
=item --socket
short form: -S; type: string
Socket file to use for connection.
=item --user
short form: -u; type: string
MySQL user if not current user.
=item --version
Show version and exit.
=item --[no]version-check
default: yes
Check for the latest version of Percona Toolkit, MySQL, and other programs.
This is a standard "check for updates automatically" feature, with two
additional features. First, the tool checks the version of other programs
on the local system in addition to its own version. For example, it checks
the version of every MySQL server it connects to, Perl, and the Perl module
DBD::mysql. Second, it checks for and warns about versions with known
problems. For example, MySQL 5.5.25 had a critical bug and was re-released
as 5.5.25a.
Any updates or known problems are printed to STDOUT before the tool's normal
output. This feature should never interfere with the normal operation of the
tool.
For more information, visit L<https://www.percona.com/version-check>.
=back
=head1 DSN OPTIONS
These DSN options are used to create a DSN. Each option is given like
C<option=value>. The options are case-sensitive, so P and p are not the
same option. There cannot be whitespace before or after the C<=> and
if the value contains whitespace it must be quoted. DSN options are
comma-separated. See the L<percona-toolkit> manpage for full details.
=over
=item * A
dsn: charset; copy: yes
Default character set.
=item * D
dsn: database; copy: yes
Default database.
=item * F
dsn: mysql_read_default_file; copy: yes
Only read default options from the given file
=item * h
dsn: host; copy: yes
Connect to host.
=item * p
dsn: password; copy: yes
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item * P
dsn: port; copy: yes
Port number to use for connection.
=item * S
dsn: mysql_socket; copy: yes
Socket file to use for connection.
=item * u
dsn: user; copy: yes
User for login if not current user.
=back
=head1 ENVIRONMENT
The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
To enable debugging and capture all output to a file, run the tool like:
PTDEBUG=1 pt-config-diff ... > FILE 2>&1
Be careful: debugging output is voluminous and can generate several megabytes
of output.
=head1 SYSTEM REQUIREMENTS
You need Perl, DBI, DBD::mysql, and some core packages that ought to be
installed in any reasonably new version of Perl.
=head1 BUGS
For a list of known bugs, see L<http://www.percona.com/bugs/pt-config-diff>.
Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C<PTDEBUG>;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L<http://www.percona.com/software/percona-toolkit/> to download the
latest release of Percona Toolkit. Or, get the latest release from the
command line:
wget percona.com/get/percona-toolkit.tar.gz
wget percona.com/get/percona-toolkit.rpm
wget percona.com/get/percona-toolkit.deb
You can also get individual tools from the latest release:
wget percona.com/get/TOOL
Replace C<TOOL> with the name of any tool.
=head1 AUTHORS
Baron Schwartz and Daniel Nichter
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools for MySQL developed by Percona. Percona Toolkit was forked from two
projects in June, 2011: Maatkit and Aspersa. Those projects were created by
Baron Schwartz and primarily developed by him and Daniel Nichter. Visit
L<http://www.percona.com/software/> to learn about other free, open-source
software from Percona.
=head1 COPYRIGHT, LICENSE, AND WARRANTY
This program is copyright 2011-2015 Percona LLC and/or its affiliates.
THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
This program is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free Software
Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
systems, you can issue `man perlgpl' or `man perlartistic' to read these
licenses.
You should have received a copy of the GNU General Public License along with
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
Place, Suite 330, Boston, MA 02111-1307 USA.
=head1 VERSION
pt-config-diff 2.2.16
=cut