percona/percona-toolkit
1
0
Fork 0
mirror of https://github.com/percona/percona-toolkit.git synced 2025-09-03 11:05:48 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
52ef2062e6850727a6dc4234e1e2c7e443081261
percona-toolkit/bin/pt-online-schema-change

5323 lines
164 KiB
Perl
Executable File
Raw Blame History

#!/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';
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
# ###########################################################################
# 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 MKDEBUG => $ENV{MKDEBUG} || 0;
use List::Util qw(max);
use Getopt::Long;
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 ) {
MKDEBUG && _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/^(Percona Toolkit v.+)$/m ) {
$self->{version} = $1;
MKDEBUG && _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;
MKDEBUG && _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;
MKDEBUG && _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 {
MKDEBUG && _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;
MKDEBUG && _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.
MKDEBUG && _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 ) {
MKDEBUG && _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;
MKDEBUG && _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;
MKDEBUG && _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;
MKDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
}
$self->{opts}->{$long} = $opt;
}
else { # It's an option rule, not a spec.
MKDEBUG && _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;
MKDEBUG && _d(@participants, 'are mutually exclusive');
}
if ( $opt =~ m/at least one|one and only one/ ) {
$rule_ok = 1;
push @{$self->{atleast1}}, \@participants;
MKDEBUG && _d(@participants, 'require at least one');
}
if ( $opt =~ m/default to/ ) {
$rule_ok = 1;
$self->{defaults_to}->{$participants[0]} = $participants[1];
MKDEBUG && _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;
MKDEBUG && _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;
MKDEBUG && _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;
}
MKDEBUG && _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};
MKDEBUG && _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}++;
}
else {
$opt->{value} = $val;
}
$opt->{got} = 1;
MKDEBUG && _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 ( MKDEBUG ) {
_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 0;
}
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;
MKDEBUG && _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 {
MKDEBUG && _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
MKDEBUG && _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';
MKDEBUG && _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;
MKDEBUG && _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
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
my $prev = {};
my $from_key = $self->{defaults_to}->{ $opt->{long} };
if ( $from_key ) {
MKDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
if ( $self->{opts}->{$from_key}->{parsed} ) {
$prev = $self->{opts}->{$from_key}->{value};
}
else {
MKDEBUG && _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
MKDEBUG && _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 {
MKDEBUG && _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} ) {
MKDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
my %synop = $self->_parse_synopsis($file);
$self->{description} ||= $synop{description};
$self->{usage} ||= $synop{usage};
MKDEBUG && _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 0 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})(?:\s+|$)/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 $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' ) {
MKDEBUG && _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};
MKDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}");
}
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__;
MKDEBUG && _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;
MKDEBUG && _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 _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 ( MKDEBUG ) {
print '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print "# $uname\n";
}
print '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# ###########################################################################
# VersionParser 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/VersionParser.pm
# t/lib/VersionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
sub new {
my ( $class ) = @_;
bless {}, $class;
}
sub parse {
my ( $self, $str ) = @_;
my $result = sprintf('%03d%03d%03d', $str =~ m/(\d+)/g);
MKDEBUG && _d($str, 'parses to', $result);
return $result;
}
sub version_ge {
my ( $self, $dbh, $target ) = @_;
if ( !$self->{$dbh} ) {
$self->{$dbh} = $self->parse(
$dbh->selectrow_array('SELECT VERSION()'));
}
my $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0;
MKDEBUG && _d($self->{$dbh}, 'ge', $target, ':', $result);
return $result;
}
sub innodb_version {
my ( $self, $dbh ) = @_;
return unless $dbh;
my $innodb_version = "NO";
my ($innodb) =
grep { $_->{engine} =~ m/InnoDB/i }
map {
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
\%hash;
}
@{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
if ( $innodb ) {
MKDEBUG && _d("InnoDB support:", $innodb->{support});
if ( $innodb->{support} =~ m/YES|DEFAULT/i ) {
my $vars = $dbh->selectrow_hashref(
"SHOW VARIABLES LIKE 'innodb_version'");
$innodb_version = !$vars ? "BUILTIN"
: ($vars->{Value} || $vars->{value});
}
else {
$innodb_version = $innodb->{support}; # probably DISABLED or NO
}
}
MKDEBUG && _d("InnoDB version:", $innodb_version);
return $innodb_version;
}
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 VersionParser 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 MKDEBUG => $ENV{MKDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Quotekeys = 0;
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);
}
MKDEBUG && _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 ) {
MKDEBUG && _d('Setting', $prop, 'property');
$self->{$prop} = $value;
}
return $self->{$prop};
}
sub parse {
my ( $self, $dsn, $prev, $defaults ) = @_;
if ( !$dsn ) {
MKDEBUG && _d('No DSN to parse');
return;
}
MKDEBUG && _d('Parsing', $dsn);
$prev ||= {};
$defaults ||= {};
my %given_props;
my %final_props;
my $opts = $self->{opts};
foreach my $dsn_part ( split(/,/, $dsn) ) {
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
$given_props{$prop_key} = $prop_val;
}
else {
MKDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
$given_props{h} = $dsn_part;
}
}
foreach my $key ( keys %$opts ) {
MKDEBUG && _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};
MKDEBUG && _d('Copying value for', $key, 'from previous DSN');
}
if ( !defined $final_props{$key} ) {
$final_props{$key} = $defaults->{$key};
MKDEBUG && _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}}
);
MKDEBUG && _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 %allowed = $props ? map { $_=>1 } @$props : ();
return join(',',
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
grep { defined $dsn->{$_} && $self->{opts}->{$_} }
grep { !$props || $allowed{$_} }
sort keys %$dsn );
}
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';
}
MKDEBUG && _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 ( $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 pgk install pkg:/SUNWpmdbi\n";
}
my $dbh;
my $tries = 2;
while ( !$dbh && $tries-- ) {
MKDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
eval {
$dbh = DBI->connect($cxn_string, $user, $pass, $defaults);
if ( $cxn_string =~ m/mysql/i ) {
my $sql;
$sql = 'SELECT @@SQL_MODE';
MKDEBUG && _d($dbh, $sql);
my ($sql_mode) = $dbh->selectrow_array($sql);
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
. ($sql_mode ? ",$sql_mode" : '')
. '\'*/';
MKDEBUG && _d($dbh, $sql);
$dbh->do($sql);
if ( my ($charset) = $cxn_string =~ m/charset=(\w+)/ ) {
$sql = "/*!40101 SET NAMES $charset*/";
MKDEBUG && _d($dbh, ':', $sql);
$dbh->do($sql);
MKDEBUG && _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 ( $self->prop('set-vars') ) {
$sql = "SET " . $self->prop('set-vars');
MKDEBUG && _d($dbh, ':', $sql);
$dbh->do($sql);
}
}
};
if ( !$dbh && $EVAL_ERROR ) {
MKDEBUG && _d($EVAL_ERROR);
if ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
MKDEBUG && _d('Going to try again without utf8 support');
delete $defaults->{mysql_enable_utf8};
}
elsif ( $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";
}
if ( !$tries ) {
die $EVAL_ERROR;
}
}
}
MKDEBUG && _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 ) = @_;
MKDEBUG && $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 _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
# ###########################################################################
# ###########################################################################
# 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 MKDEBUG => $ENV{MKDEBUG} || 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});
MKDEBUG && _d('Daemonized child will log to', $self->{log_file});
return bless $self, $class;
}
sub daemonize {
my ( $self ) = @_;
MKDEBUG && _d('About to fork and daemonize');
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
if ( $pid ) {
MKDEBUG && _d('I am the parent and now I die');
exit;
}
$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;
if ( -t STDIN ) {
close STDIN;
open STDIN, '/dev/null'
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
}
if ( $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 ) {
close STDOUT;
open STDOUT, '>', '/dev/null'
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
}
if ( -t STDERR ) {
close STDERR;
open STDERR, '>', '/dev/null'
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
}
}
MKDEBUG && _d('I am the child and now I live daemonized');
return;
}
sub check_PID_file {
my ( $self, $file ) = @_;
my $PID_file = $self ? $self->{PID_file} : $file;
MKDEBUG && _d('Checking PID file', $PID_file);
if ( $PID_file && -f $PID_file ) {
my $pid;
eval { chomp($pid = `cat $PID_file`); };
die "Cannot cat $PID_file: $OS_ERROR" if $EVAL_ERROR;
MKDEBUG && _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 {
MKDEBUG && _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 ) {
MKDEBUG && _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";
MKDEBUG && _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";
MKDEBUG && _d('Removed PID file');
}
else {
MKDEBUG && _d('No PID to remove');
}
return;
}
sub DESTROY {
my ( $self ) = @_;
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
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 Daemon package
# ###########################################################################
# ###########################################################################
# Quoter 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/Quoter.pm
# t/lib/Quoter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Quoter;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
return bless {}, $class;
}
sub quote {
my ( $self, @vals ) = @_;
foreach my $val ( @vals ) {
$val =~ s/`/``/g;
}
return join('.', map { '`' . $_ . '`' } @vals);
}
sub quote_val {
my ( $self, $val ) = @_;
return 'NULL' unless defined $val; # undef = NULL
return "''" if $val eq ''; # blank string = ''
return $val if $val =~ m/^0x[0-9a-fA-F]+$/; # hex data
$val =~ s/(['\\])/\\$1/g;
return "'$val'";
}
sub split_unquote {
my ( $self, $db_tbl, $default_db ) = @_;
$db_tbl =~ s/`//g;
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
return ($db, $tbl);
}
sub literal_like {
my ( $self, $like ) = @_;
return unless $like;
$like =~ s/([%_])/\\$1/g;
return "'$like'";
}
sub join_quote {
my ( $self, $default_db, $db_tbl ) = @_;
return unless $db_tbl;
my ($db, $tbl) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
$db = "`$db`" if $db && $db !~ m/^`/;
$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
return $db ? "$db.$tbl" : $tbl;
}
1;
}
# ###########################################################################
# End Quoter package
# ###########################################################################
# ###########################################################################
# Transformers 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/Transformers.pm
# t/lib/Transformers.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Transformers;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use Time::Local qw(timegm timelocal);
use Digest::MD5 qw(md5_hex);
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ();
our @EXPORT = ();
our @EXPORT_OK = qw(
micro_t
percentage_of
secs_to_time
time_to_secs
shorten
ts
parse_timestamp
unix_timestamp
any_unix_timestamp
make_checksum
crc32
);
our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
sub micro_t {
my ( $t, %args ) = @_;
my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
my $f;
$t = 0 if $t < 0;
$t = sprintf('%.17f', $t) if $t =~ /e/;
$t =~ s/\.(\d{1,6})\d*/\.$1/;
if ($t > 0 && $t <= 0.000999) {
$f = ($t * 1000000) . 'us';
}
elsif ($t >= 0.001000 && $t <= 0.999999) {
$f = sprintf("%.${p_ms}f", $t * 1000);
$f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
}
elsif ($t >= 1) {
$f = sprintf("%.${p_s}f", $t);
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
}
else {
$f = 0; # $t should = 0 at this point
}
return $f;
}
sub percentage_of {
my ( $is, $of, %args ) = @_;
my $p = $args{p} || 0; # float precision
my $fmt = $p ? "%.${p}f" : "%d";
return sprintf $fmt, ($is * 100) / ($of ||= 1);
}
sub secs_to_time {
my ( $secs, $fmt ) = @_;
$secs ||= 0;
return '00:00' unless $secs;
$fmt ||= $secs >= 86_400 ? 'd'
: $secs >= 3_600 ? 'h'
: 'm';
return
$fmt eq 'd' ? sprintf(
"%d+%02d:%02d:%02d",
int($secs / 86_400),
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: $fmt eq 'h' ? sprintf(
"%02d:%02d:%02d",
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: sprintf(
"%02d:%02d",
int(($secs % 3_600) / 60),
$secs % 60);
}
sub time_to_secs {
my ( $val, $default_suffix ) = @_;
die "I need a val argument" unless defined $val;
my $t = 0;
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
$suffix = $suffix || $default_suffix || 's';
if ( $suffix =~ m/[smhd]/ ) {
$t = $suffix eq 's' ? $num * 1 # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$t *= -1 if $prefix && $prefix eq '-';
}
else {
die "Invalid suffix for $val: $suffix";
}
return $t;
}
sub shorten {
my ( $num, %args ) = @_;
my $p = defined $args{p} ? $args{p} : 2; # float precision
my $d = defined $args{d} ? $args{d} : 1_024; # divisor
my $n = 0;
my @units = ('', qw(k M G T P E Z Y));
while ( $num >= $d && $n < @units - 1 ) {
$num /= $d;
++$n;
}
return sprintf(
$num =~ m/\./ || $n
? "%.${p}f%s"
: '%d',
$num, $units[$n]);
}
sub ts {
my ( $time, $gmt ) = @_;
my ( $sec, $min, $hour, $mday, $mon, $year )
= $gmt ? gmtime($time) : localtime($time);
$mon += 1;
$year += 1900;
my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
$us = sprintf("%.6f", $us);
$us =~ s/^0\././;
$val .= $us;
}
return $val;
}
sub parse_timestamp {
my ( $val ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $f)
= $val =~ m/^$mysql_ts$/ )
{
return sprintf "%d-%02d-%02d %02d:%02d:"
. (defined $f ? '%09.6f' : '%02d'),
$y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
}
return $val;
}
sub unix_timestamp {
my ( $val, $gmt ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
$val = $gmt
? timegm($s, $i, $h, $d, $m - 1, $y)
: timelocal($s, $i, $h, $d, $m - 1, $y);
if ( defined $us ) {
$us = sprintf('%.6f', $us);
$us =~ s/^0\././;
$val .= $us;
}
}
return $val;
}
sub any_unix_timestamp {
my ( $val, $callback ) = @_;
if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
$n = $suffix eq 's' ? $n # Seconds
: $suffix eq 'm' ? $n * 60 # Minutes
: $suffix eq 'h' ? $n * 3600 # Hours
: $suffix eq 'd' ? $n * 86400 # Days
: $n; # default: Seconds
MKDEBUG && _d('ts is now - N[shmd]:', $n);
return time - $n;
}
elsif ( $val =~ m/^\d{9,}/ ) {
MKDEBUG && _d('ts is already a unix timestamp');
return $val;
}
elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
MKDEBUG && _d('ts is MySQL slow log timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp(parse_timestamp($val));
}
elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
MKDEBUG && _d('ts is properly formatted timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp($val);
}
else {
MKDEBUG && _d('ts is MySQL expression');
return $callback->($val) if $callback && ref $callback eq 'CODE';
}
MKDEBUG && _d('Unknown ts type:', $val);
return;
}
sub make_checksum {
my ( $val ) = @_;
my $checksum = uc substr(md5_hex($val), -16);
MKDEBUG && _d($checksum, 'checksum for', $val);
return $checksum;
}
sub crc32 {
my ( $string ) = @_;
return unless $string;
my $poly = 0xEDB88320;
my $crc = 0xFFFFFFFF;
foreach my $char ( split(//, $string) ) {
my $comp = ($crc ^ ord($char)) & 0xFF;
for ( 1 .. 8 ) {
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
}
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
}
return $crc ^ 0xFFFFFFFF;
}
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 Transformers package
# ###########################################################################
# ###########################################################################
# TableParser 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/TableParser.pm
# t/lib/TableParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package TableParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = { %args };
return bless $self, $class;
}
sub parse {
my ( $self, $ddl, $opts ) = @_;
return unless $ddl;
if ( ref $ddl eq 'ARRAY' ) {
if ( lc $ddl->[0] eq 'table' ) {
$ddl = $ddl->[1];
}
else {
return {
engine => 'VIEW',
};
}
}
if ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
die "Cannot parse table definition; is ANSI quoting "
. "enabled or SQL_QUOTE_SHOW_CREATE disabled?";
}
my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
(undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
$ddl =~ s/(`[^`]+`)/\L$1/g;
my $engine = $self->get_engine($ddl);
my @defs = $ddl =~ m/^(\s+`.*?),?$/gm;
my @cols = map { $_ =~ m/`([^`]+)`/ } @defs;
MKDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols));
my %def_for;
@def_for{@cols} = @defs;
my (@nums, @null);
my (%type_for, %is_nullable, %is_numeric, %is_autoinc);
foreach my $col ( @cols ) {
my $def = $def_for{$col};
my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
die "Can't determine column type for $def" unless $type;
$type_for{$col} = $type;
if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) {
push @nums, $col;
$is_numeric{$col} = 1;
}
if ( $def !~ m/NOT NULL/ ) {
push @null, $col;
$is_nullable{$col} = 1;
}
$is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
}
my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable);
my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/;
return {
name => $name,
cols => \@cols,
col_posn => { map { $cols[$_] => $_ } 0..$#cols },
is_col => { map { $_ => 1 } @cols },
null_cols => \@null,
is_nullable => \%is_nullable,
is_autoinc => \%is_autoinc,
clustered_key => $clustered_key,
keys => $keys,
defs => \%def_for,
numeric_cols => \@nums,
is_numeric => \%is_numeric,
engine => $engine,
type_for => \%type_for,
charset => $charset,
};
}
sub sort_indexes {
my ( $self, $tbl ) = @_;
my @indexes
= sort {
(($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
|| ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
|| ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
|| ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
}
grep {
$tbl->{keys}->{$_}->{type} eq 'BTREE'
}
sort keys %{$tbl->{keys}};
MKDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
return @indexes;
}
sub find_best_index {
my ( $self, $tbl, $index ) = @_;
my $best;
if ( $index ) {
($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
}
if ( !$best ) {
if ( $index ) {
die "Index '$index' does not exist in table";
}
else {
($best) = $self->sort_indexes($tbl);
}
}
MKDEBUG && _d('Best index found is', $best);
return $best;
}
sub find_possible_keys {
my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
return () unless $where;
my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
. ' WHERE ' . $where;
MKDEBUG && _d($sql);
my $expl = $dbh->selectrow_hashref($sql);
$expl = { map { lc($_) => $expl->{$_} } keys %$expl };
if ( $expl->{possible_keys} ) {
MKDEBUG && _d('possible_keys =', $expl->{possible_keys});
my @candidates = split(',', $expl->{possible_keys});
my %possible = map { $_ => 1 } @candidates;
if ( $expl->{key} ) {
MKDEBUG && _d('MySQL chose', $expl->{key});
unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
MKDEBUG && _d('Before deduping:', join(', ', @candidates));
my %seen;
@candidates = grep { !$seen{$_}++ } @candidates;
}
MKDEBUG && _d('Final list:', join(', ', @candidates));
return @candidates;
}
else {
MKDEBUG && _d('No keys in possible_keys');
return ();
}
}
sub check_table {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $tbl) = @args{@required_args};
my $q = $self->{Quoter};
my $db_tbl = $q->quote($db, $tbl);
MKDEBUG && _d('Checking', $db_tbl);
my $sql = "SHOW TABLES FROM " . $q->quote($db)
. ' LIKE ' . $q->literal_like($tbl);
MKDEBUG && _d($sql);
my $row;
eval {
$row = $dbh->selectrow_arrayref($sql);
};
if ( $EVAL_ERROR ) {
MKDEBUG && _d($EVAL_ERROR);
return 0;
}
if ( !$row->[0] || $row->[0] ne $tbl ) {
MKDEBUG && _d('Table does not exist');
return 0;
}
MKDEBUG && _d('Table exists; no privs to check');
return 1 unless $args{all_privs};
$sql = "SHOW FULL COLUMNS FROM $db_tbl";
MKDEBUG && _d($sql);
eval {
$row = $dbh->selectrow_hashref($sql);
};
if ( $EVAL_ERROR ) {
MKDEBUG && _d($EVAL_ERROR);
return 0;
}
if ( !scalar keys %$row ) {
MKDEBUG && _d('Table has no columns:', Dumper($row));
return 0;
}
my $privs = $row->{privileges} || $row->{Privileges};
$sql = "DELETE FROM $db_tbl LIMIT 0";
MKDEBUG && _d($sql);
eval {
$dbh->do($sql);
};
my $can_delete = $EVAL_ERROR ? 0 : 1;
MKDEBUG && _d('User privs on', $db_tbl, ':', $privs,
($can_delete ? 'delete' : ''));
if ( !($privs =~ m/select/ && $privs =~ m/insert/ && $privs =~ m/update/
&& $can_delete) ) {
MKDEBUG && _d('User does not have all privs');
return 0;
}
MKDEBUG && _d('User has all privs');
return 1;
}
sub get_engine {
my ( $self, $ddl, $opts ) = @_;
my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
MKDEBUG && _d('Storage engine:', $engine);
return $engine || undef;
}
sub get_keys {
my ( $self, $ddl, $opts, $is_nullable ) = @_;
my $engine = $self->get_engine($ddl);
my $keys = {};
my $clustered_key = undef;
KEY:
foreach my $key ( $ddl =~ m/^ ((?:[A-Z]+ )?KEY .*)$/gm ) {
next KEY if $key =~ m/FOREIGN/;
my $key_ddl = $key;
MKDEBUG && _d('Parsed key:', $key_ddl);
if ( $engine !~ m/MEMORY|HEAP/ ) {
$key =~ s/USING HASH/USING BTREE/;
}
my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/;
my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/;
$type = $type || $special || 'BTREE';
if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000'
&& $engine =~ m/HEAP|MEMORY/i )
{
$type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP
}
my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/;
my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0;
my @cols;
my @col_prefixes;
foreach my $col_def ( $cols =~ m/`[^`]+`(?:\(\d+\))?/g ) {
my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/;
push @cols, $name;
push @col_prefixes, $prefix;
}
$name =~ s/`//g;
MKDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols));
$keys->{$name} = {
name => $name,
type => $type,
colnames => $cols,
cols => \@cols,
col_prefixes => \@col_prefixes,
is_unique => $unique,
is_nullable => scalar(grep { $is_nullable->{$_} } @cols),
is_col => { map { $_ => 1 } @cols },
ddl => $key_ddl,
};
if ( $engine =~ m/InnoDB/i && !$clustered_key ) {
my $this_key = $keys->{$name};
if ( $this_key->{name} eq 'PRIMARY' ) {
$clustered_key = 'PRIMARY';
}
elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) {
$clustered_key = $this_key->{name};
}
MKDEBUG && $clustered_key && _d('This key is the clustered key');
}
}
return $keys, $clustered_key;
}
sub get_fks {
my ( $self, $ddl, $opts ) = @_;
my $q = $self->{Quoter};
my $fks = {};
foreach my $fk (
$ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
{
my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/;
my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/;
my ($db, $tbl) = $q->split_unquote($parent, $opts->{database});
my %parent_tbl = (tbl => $tbl);
$parent_tbl{db} = $db if $db;
if ( $parent !~ m/\./ && $opts->{database} ) {
$parent = $q->quote($opts->{database}) . ".$parent";
}
$fks->{$name} = {
name => $name,
colnames => $cols,
cols => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
parent_tbl => \%parent_tbl,
parent_tblname => $parent,
parent_cols => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
parent_colnames=> $parent_cols,
ddl => $fk,
};
}
return $fks;
}
sub remove_auto_increment {
my ( $self, $ddl ) = @_;
$ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
return $ddl;
}
sub remove_secondary_indexes {
my ( $self, $ddl ) = @_;
my $sec_indexes_ddl;
my $tbl_struct = $self->parse($ddl);
if ( ($tbl_struct->{engine} || '') =~ m/InnoDB/i ) {
my $clustered_key = $tbl_struct->{clustered_key};
$clustered_key ||= '';
my @sec_indexes = map {
my $key_def = $_->{ddl};
$key_def =~ s/([\(\)])/\\$1/g;
$ddl =~ s/\s+$key_def//i;
my $key_ddl = "ADD $_->{ddl}";
$key_ddl .= ',' unless $key_ddl =~ m/,$/;
$key_ddl;
}
grep { $_->{name} ne $clustered_key }
values %{$tbl_struct->{keys}};
MKDEBUG && _d('Secondary indexes:', Dumper(\@sec_indexes));
if ( @sec_indexes ) {
$sec_indexes_ddl = join(' ', @sec_indexes);
$sec_indexes_ddl =~ s/,$//;
}
$ddl =~ s/,(\n\) )/$1/s;
}
else {
MKDEBUG && _d('Not removing secondary indexes from',
$tbl_struct->{engine}, 'table');
}
return $ddl, $sec_indexes_ddl, $tbl_struct;
}
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 TableParser package
# ###########################################################################
# ###########################################################################
# MySQLDump 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/MySQLDump.pm
# t/lib/MySQLDump.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MySQLDump;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
( our $before = <<'EOF') =~ s/^ //gm;
/*!40101 SET @OLD_CHARACTER_SET_CLIENT=@@CHARACTER_SET_CLIENT */;
/*!40101 SET @OLD_CHARACTER_SET_RESULTS=@@CHARACTER_SET_RESULTS */;
/*!40101 SET @OLD_COLLATION_CONNECTION=@@COLLATION_CONNECTION */;
/*!40101 SET NAMES utf8 */;
/*!40103 SET @OLD_TIME_ZONE=@@TIME_ZONE */;
/*!40103 SET TIME_ZONE='+00:00' */;
/*!40014 SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0 */;
/*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */;
/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO' */;
/*!40111 SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0 */;
EOF
( our $after = <<'EOF') =~ s/^ //gm;
/*!40103 SET TIME_ZONE=@OLD_TIME_ZONE */;
/*!40101 SET SQL_MODE=@OLD_SQL_MODE */;
/*!40014 SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS */;
/*!40014 SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS */;
/*!40101 SET CHARACTER_SET_CLIENT=@OLD_CHARACTER_SET_CLIENT */;
/*!40101 SET CHARACTER_SET_RESULTS=@OLD_CHARACTER_SET_RESULTS */;
/*!40101 SET COLLATION_CONNECTION=@OLD_COLLATION_CONNECTION */;
/*!40111 SET SQL_NOTES=@OLD_SQL_NOTES */;
EOF
sub new {
my ( $class, %args ) = @_;
my $self = {
cache => 0, # Afaik no script uses this cache any longer because
};
return bless $self, $class;
}
sub dump {
my ( $self, $dbh, $quoter, $db, $tbl, $what ) = @_;
if ( $what eq 'table' ) {
my $ddl = $self->get_create_table($dbh, $quoter, $db, $tbl);
return unless $ddl;
if ( $ddl->[0] eq 'table' ) {
return $before
. 'DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . ";\n"
. $ddl->[1] . ";\n";
}
else {
return 'DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . ";\n"
. '/*!50001 DROP VIEW IF EXISTS '
. $quoter->quote($tbl) . "*/;\n/*!50001 "
. $self->get_tmp_table($dbh, $quoter, $db, $tbl) . "*/;\n";
}
}
elsif ( $what eq 'triggers' ) {
my $trgs = $self->get_triggers($dbh, $quoter, $db, $tbl);
if ( $trgs && @$trgs ) {
my $result = $before . "\nDELIMITER ;;\n";
foreach my $trg ( @$trgs ) {
if ( $trg->{sql_mode} ) {
$result .= qq{/*!50003 SET SESSION SQL_MODE='$trg->{sql_mode}' */;;\n};
}
$result .= "/*!50003 CREATE */ ";
if ( $trg->{definer} ) {
my ( $user, $host )
= map { s/'/''/g; "'$_'"; }
split('@', $trg->{definer}, 2);
$result .= "/*!50017 DEFINER=$user\@$host */ ";
}
$result .= sprintf("/*!50003 TRIGGER %s %s %s ON %s\nFOR EACH ROW %s */;;\n\n",
$quoter->quote($trg->{trigger}),
@{$trg}{qw(timing event)},
$quoter->quote($trg->{table}),
$trg->{statement});
}
$result .= "DELIMITER ;\n\n/*!50003 SET SESSION SQL_MODE=\@OLD_SQL_MODE */;\n\n";
return $result;
}
else {
return undef;
}
}
elsif ( $what eq 'view' ) {
my $ddl = $self->get_create_table($dbh, $quoter, $db, $tbl);
return '/*!50001 DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . "*/;\n"
. '/*!50001 DROP VIEW IF EXISTS ' . $quoter->quote($tbl) . "*/;\n"
. '/*!50001 ' . $ddl->[1] . "*/;\n";
}
else {
die "You didn't say what to dump.";
}
}
sub _use_db {
my ( $self, $dbh, $quoter, $new ) = @_;
if ( !$new ) {
MKDEBUG && _d('No new DB to use');
return;
}
my $sql = 'USE ' . $quoter->quote($new);
MKDEBUG && _d($dbh, $sql);
$dbh->do($sql);
return;
}
sub get_create_table {
my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
if ( !$self->{cache} || !$self->{tables}->{$db}->{$tbl} ) {
my $sql = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
. q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
. '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
. '@@SQL_QUOTE_SHOW_CREATE := 1 */';
MKDEBUG && _d($sql);
eval { $dbh->do($sql); };
MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
$self->_use_db($dbh, $quoter, $db);
$sql = "SHOW CREATE TABLE " . $quoter->quote($db, $tbl);
MKDEBUG && _d($sql);
my $href;
eval { $href = $dbh->selectrow_hashref($sql); };
if ( $EVAL_ERROR ) {
warn "Failed to $sql. The table may be damaged.\nError: $EVAL_ERROR";
return;
}
$sql = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
. '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
MKDEBUG && _d($sql);
$dbh->do($sql);
my ($key) = grep { m/create table/i } keys %$href;
if ( $key ) {
MKDEBUG && _d('This table is a base table');
$self->{tables}->{$db}->{$tbl} = [ 'table', $href->{$key} ];
}
else {
MKDEBUG && _d('This table is a view');
($key) = grep { m/create view/i } keys %$href;
$self->{tables}->{$db}->{$tbl} = [ 'view', $href->{$key} ];
}
}
return $self->{tables}->{$db}->{$tbl};
}
sub get_columns {
my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
MKDEBUG && _d('Get columns for', $db, $tbl);
if ( !$self->{cache} || !$self->{columns}->{$db}->{$tbl} ) {
$self->_use_db($dbh, $quoter, $db);
my $sql = "SHOW COLUMNS FROM " . $quoter->quote($db, $tbl);
MKDEBUG && _d($sql);
my $cols = $dbh->selectall_arrayref($sql, { Slice => {} });
$self->{columns}->{$db}->{$tbl} = [
map {
my %row;
@row{ map { lc $_ } keys %$_ } = values %$_;
\%row;
} @$cols
];
}
return $self->{columns}->{$db}->{$tbl};
}
sub get_tmp_table {
my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
my $result = 'CREATE TABLE ' . $quoter->quote($tbl) . " (\n";
$result .= join(",\n",
map { ' ' . $quoter->quote($_->{field}) . ' ' . $_->{type} }
@{$self->get_columns($dbh, $quoter, $db, $tbl)});
$result .= "\n)";
MKDEBUG && _d($result);
return $result;
}
sub get_triggers {
my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
if ( !$self->{cache} || !$self->{triggers}->{$db} ) {
$self->{triggers}->{$db} = {};
my $sql = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
. q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
. '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
. '@@SQL_QUOTE_SHOW_CREATE := 1 */';
MKDEBUG && _d($sql);
eval { $dbh->do($sql); };
MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
$sql = "SHOW TRIGGERS FROM " . $quoter->quote($db);
MKDEBUG && _d($sql);
my $sth = $dbh->prepare($sql);
$sth->execute();
if ( $sth->rows ) {
my $trgs = $sth->fetchall_arrayref({});
foreach my $trg (@$trgs) {
my %trg;
@trg{ map { lc $_ } keys %$trg } = values %$trg;
push @{ $self->{triggers}->{$db}->{ $trg{table} } }, \%trg;
}
}
$sql = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
. '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
MKDEBUG && _d($sql);
$dbh->do($sql);
}
if ( $tbl ) {
return $self->{triggers}->{$db}->{$tbl};
}
return values %{$self->{triggers}->{$db}};
}
sub get_databases {
my ( $self, $dbh, $quoter, $like ) = @_;
if ( !$self->{cache} || !$self->{databases} || $like ) {
my $sql = 'SHOW DATABASES';
my @params;
if ( $like ) {
$sql .= ' LIKE ?';
push @params, $like;
}
my $sth = $dbh->prepare($sql);
MKDEBUG && _d($sql, @params);
$sth->execute( @params );
my @dbs = map { $_->[0] } @{$sth->fetchall_arrayref()};
$self->{databases} = \@dbs unless $like;
return @dbs;
}
return @{$self->{databases}};
}
sub get_table_status {
my ( $self, $dbh, $quoter, $db, $like ) = @_;
if ( !$self->{cache} || !$self->{table_status}->{$db} || $like ) {
my $sql = "SHOW TABLE STATUS FROM " . $quoter->quote($db);
my @params;
if ( $like ) {
$sql .= ' LIKE ?';
push @params, $like;
}
MKDEBUG && _d($sql, @params);
my $sth = $dbh->prepare($sql);
$sth->execute(@params);
my @tables = @{$sth->fetchall_arrayref({})};
@tables = map {
my %tbl; # Make a copy with lowercased keys
@tbl{ map { lc $_ } keys %$_ } = values %$_;
$tbl{engine} ||= $tbl{type} || $tbl{comment};
delete $tbl{type};
\%tbl;
} @tables;
$self->{table_status}->{$db} = \@tables unless $like;
return @tables;
}
return @{$self->{table_status}->{$db}};
}
sub get_table_list {
my ( $self, $dbh, $quoter, $db, $like ) = @_;
if ( !$self->{cache} || !$self->{table_list}->{$db} || $like ) {
my $sql = "SHOW /*!50002 FULL*/ TABLES FROM " . $quoter->quote($db);
my @params;
if ( $like ) {
$sql .= ' LIKE ?';
push @params, $like;
}
MKDEBUG && _d($sql, @params);
my $sth = $dbh->prepare($sql);
$sth->execute(@params);
my @tables = @{$sth->fetchall_arrayref()};
@tables = map {
my %tbl = (
name => $_->[0],
engine => ($_->[1] || '') eq 'VIEW' ? 'VIEW' : '',
);
\%tbl;
} @tables;
$self->{table_list}->{$db} = \@tables unless $like;
return @tables;
}
return @{$self->{table_list}->{$db}};
}
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 MySQLDump package
# ###########################################################################
# ###########################################################################
# TableChunker 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/TableChunker.pm
# t/lib/TableChunker.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package TableChunker;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
use POSIX qw(floor ceil);
use List::Util qw(min max);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
sub new {
my ( $class, %args ) = @_;
foreach my $arg ( qw(Quoter MySQLDump) ) {
die "I need a $arg argument" unless $args{$arg};
}
my %int_types = map { $_ => 1 } qw(bigint date datetime int mediumint smallint time timestamp tinyint year);
my %real_types = map { $_ => 1 } qw(decimal double float);
my $self = {
%args,
int_types => \%int_types,
real_types => \%real_types,
EPOCH => '1970-01-01',
};
return bless $self, $class;
}
sub find_chunk_columns {
my ( $self, %args ) = @_;
foreach my $arg ( qw(tbl_struct) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $tbl_struct = $args{tbl_struct};
my @possible_indexes;
foreach my $index ( values %{ $tbl_struct->{keys} } ) {
next unless $index->{type} eq 'BTREE';
next if grep { defined } @{$index->{col_prefixes}};
if ( $args{exact} ) {
next unless $index->{is_unique} && @{$index->{cols}} == 1;
}
push @possible_indexes, $index;
}
MKDEBUG && _d('Possible chunk indexes in order:',
join(', ', map { $_->{name} } @possible_indexes));
my $can_chunk_exact = 0;
my @candidate_cols;
foreach my $index ( @possible_indexes ) {
my $col = $index->{cols}->[0];
my $col_type = $tbl_struct->{type_for}->{$col};
next unless $self->{int_types}->{$col_type}
|| $self->{real_types}->{$col_type}
|| $col_type =~ m/char/;
push @candidate_cols, { column => $col, index => $index->{name} };
}
$can_chunk_exact = 1 if $args{exact} && scalar @candidate_cols;
if ( MKDEBUG ) {
my $chunk_type = $args{exact} ? 'Exact' : 'Inexact';
_d($chunk_type, 'chunkable:',
join(', ', map { "$_->{column} on $_->{index}" } @candidate_cols));
}
my @result;
MKDEBUG && _d('Ordering columns by order in tbl, PK first');
if ( $tbl_struct->{keys}->{PRIMARY} ) {
my $pk_first_col = $tbl_struct->{keys}->{PRIMARY}->{cols}->[0];
@result = grep { $_->{column} eq $pk_first_col } @candidate_cols;
@candidate_cols = grep { $_->{column} ne $pk_first_col } @candidate_cols;
}
my $i = 0;
my %col_pos = map { $_ => $i++ } @{$tbl_struct->{cols}};
push @result, sort { $col_pos{$a->{column}} <=> $col_pos{$b->{column}} }
@candidate_cols;
if ( MKDEBUG ) {
_d('Chunkable columns:',
join(', ', map { "$_->{column} on $_->{index}" } @result));
_d('Can chunk exactly:', $can_chunk_exact);
}
return ($can_chunk_exact, @result);
}
sub calculate_chunks {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl tbl_struct chunk_col rows_in_range chunk_size);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
MKDEBUG && _d('Calculate chunks for',
join(", ", map {"$_=".(defined $args{$_} ? $args{$_} : "undef")}
qw(db tbl chunk_col min max rows_in_range chunk_size zero_chunk exact)
));
if ( !$args{rows_in_range} ) {
MKDEBUG && _d("Empty table");
return '1=1';
}
if ( $args{rows_in_range} < $args{chunk_size} ) {
MKDEBUG && _d("Chunk size larger than rows in range");
return '1=1';
}
my $q = $self->{Quoter};
my $dbh = $args{dbh};
my $chunk_col = $args{chunk_col};
my $tbl_struct = $args{tbl_struct};
my $col_type = $tbl_struct->{type_for}->{$chunk_col};
MKDEBUG && _d('chunk col type:', $col_type);
my %chunker;
if ( $tbl_struct->{is_numeric}->{$chunk_col} || $col_type =~ /date|time/ ) {
%chunker = $self->_chunk_numeric(%args);
}
elsif ( $col_type =~ m/char/ ) {
%chunker = $self->_chunk_char(%args);
}
else {
die "Cannot chunk $col_type columns";
}
MKDEBUG && _d("Chunker:", Dumper(\%chunker));
my ($col, $start_point, $end_point, $interval, $range_func)
= @chunker{qw(col start_point end_point interval range_func)};
my @chunks;
if ( $start_point < $end_point ) {
push @chunks, "$col = 0" if $chunker{have_zero_chunk};
my ($beg, $end);
my $iter = 0;
for ( my $i = $start_point; $i < $end_point; $i += $interval ) {
($beg, $end) = $self->$range_func($dbh, $i, $interval, $end_point);
if ( $iter++ == 0 ) {
push @chunks,
($chunker{have_zero_chunk} ? "$col > 0 AND " : "")
."$col < " . $q->quote_val($end);
}
else {
push @chunks, "$col >= " . $q->quote_val($beg) . " AND $col < " . $q->quote_val($end);
}
}
my $chunk_range = lc $args{chunk_range} || 'open';
my $nullable = $args{tbl_struct}->{is_nullable}->{$args{chunk_col}};
pop @chunks;
if ( @chunks ) {
push @chunks, "$col >= " . $q->quote_val($beg)
. ($chunk_range eq 'openclosed'
? " AND $col <= " . $q->quote_val($args{max}) : "");
}
else {
push @chunks, $nullable ? "$col IS NOT NULL" : '1=1';
}
if ( $nullable ) {
push @chunks, "$col IS NULL";
}
}
else {
MKDEBUG && _d('No chunks; using single chunk 1=1');
push @chunks, '1=1';
}
return @chunks;
}
sub _chunk_numeric {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl tbl_struct chunk_col rows_in_range chunk_size);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my $q = $self->{Quoter};
my $db_tbl = $q->quote($args{db}, $args{tbl});
my $col_type = $args{tbl_struct}->{type_for}->{$args{chunk_col}};
my $range_func;
if ( $col_type =~ m/(?:int|year|float|double|decimal)$/ ) {
$range_func = 'range_num';
}
elsif ( $col_type =~ m/^(?:timestamp|date|time)$/ ) {
$range_func = "range_$col_type";
}
elsif ( $col_type eq 'datetime' ) {
$range_func = 'range_datetime';
}
my ($start_point, $end_point);
eval {
$start_point = $self->value_to_number(
value => $args{min},
column_type => $col_type,
dbh => $args{dbh},
);
$end_point = $self->value_to_number(
value => $args{max},
column_type => $col_type,
dbh => $args{dbh},
);
};
if ( $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/don't know how to chunk/ ) {
die $EVAL_ERROR;
}
else {
die "Error calculating chunk start and end points for table "
. "`$args{tbl_struct}->{name}` on column `$args{chunk_col}` "
. "with min/max values "
. join('/',
map { defined $args{$_} ? $args{$_} : 'undef' } qw(min max))
. ":\n\n"
. $EVAL_ERROR
. "\nVerify that the min and max values are valid for the column. "
. "If they are valid, this error could be caused by a bug in the "
. "tool.";
}
}
if ( !defined $start_point ) {
MKDEBUG && _d('Start point is undefined');
$start_point = 0;
}
if ( !defined $end_point || $end_point < $start_point ) {
MKDEBUG && _d('End point is undefined or before start point');
$end_point = 0;
}
MKDEBUG && _d("Actual chunk range:", $start_point, "to", $end_point);
my $have_zero_chunk = 0;
if ( $args{zero_chunk} ) {
if ( $start_point != $end_point && $start_point >= 0 ) {
MKDEBUG && _d('Zero chunking');
my $nonzero_val = $self->get_nonzero_value(
%args,
db_tbl => $db_tbl,
col => $args{chunk_col},
col_type => $col_type,
val => $args{min}
);
$start_point = $self->value_to_number(
value => $nonzero_val,
column_type => $col_type,
dbh => $args{dbh},
);
$have_zero_chunk = 1;
}
else {
MKDEBUG && _d("Cannot zero chunk");
}
}
MKDEBUG && _d("Using chunk range:", $start_point, "to", $end_point);
my $interval = $args{chunk_size}
* ($end_point - $start_point)
/ $args{rows_in_range};
if ( $self->{int_types}->{$col_type} ) {
$interval = ceil($interval);
}
$interval ||= $args{chunk_size};
if ( $args{exact} ) {
$interval = $args{chunk_size};
}
MKDEBUG && _d('Chunk interval:', $interval, 'units');
return (
col => $q->quote($args{chunk_col}),
start_point => $start_point,
end_point => $end_point,
interval => $interval,
range_func => $range_func,
have_zero_chunk => $have_zero_chunk,
);
}
sub _chunk_char {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl tbl_struct chunk_col rows_in_range chunk_size);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my $q = $self->{Quoter};
my $db_tbl = $q->quote($args{db}, $args{tbl});
my $dbh = $args{dbh};
my $chunk_col = $args{chunk_col};
my $row;
my $sql;
$sql = "SELECT MIN($chunk_col), MAX($chunk_col) FROM $db_tbl "
. "ORDER BY `$chunk_col`";
MKDEBUG && _d($dbh, $sql);
$row = $dbh->selectrow_arrayref($sql);
my ($min_col, $max_col) = ($row->[0], $row->[1]);
$sql = "SELECT ORD(?) AS min_col_ord, ORD(?) AS max_col_ord";
MKDEBUG && _d($dbh, $sql);
my $ord_sth = $dbh->prepare($sql); # avoid quoting issues
$ord_sth->execute($min_col, $max_col);
$row = $ord_sth->fetchrow_arrayref();
my ($min_col_ord, $max_col_ord) = ($row->[0], $row->[1]);
MKDEBUG && _d("Min/max col char code:", $min_col_ord, $max_col_ord);
my $base;
my @chars;
MKDEBUG && _d("Table charset:", $args{tbl_struct}->{charset});
if ( ($args{tbl_struct}->{charset} || "") eq "latin1" ) {
my @sorted_latin1_chars = (
32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59,
60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73,
74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87,
88, 89, 90, 91, 92, 93, 94, 95, 96, 123, 124, 125, 126, 161,
162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175,
176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189,
190, 191, 215, 216, 222, 223, 247, 255);
my ($first_char, $last_char);
for my $i ( 0..$#sorted_latin1_chars ) {
$first_char = $i and last if $sorted_latin1_chars[$i] >= $min_col_ord;
}
for my $i ( $first_char..$#sorted_latin1_chars ) {
$last_char = $i and last if $sorted_latin1_chars[$i] >= $max_col_ord;
};
@chars = map { chr $_; } @sorted_latin1_chars[$first_char..$last_char];
$base = scalar @chars;
}
else {
my $tmp_tbl = '__maatkit_char_chunking_map';
my $tmp_db_tbl = $q->quote($args{db}, $tmp_tbl);
$sql = "DROP TABLE IF EXISTS $tmp_db_tbl";
MKDEBUG && _d($dbh, $sql);
$dbh->do($sql);
my $col_def = $args{tbl_struct}->{defs}->{$chunk_col};
$sql = "CREATE TEMPORARY TABLE $tmp_db_tbl ($col_def) "
. "ENGINE=MEMORY";
MKDEBUG && _d($dbh, $sql);
$dbh->do($sql);
$sql = "INSERT INTO $tmp_db_tbl VALUE (CHAR(?))";
MKDEBUG && _d($dbh, $sql);
my $ins_char_sth = $dbh->prepare($sql); # avoid quoting issues
for my $char_code ( $min_col_ord..$max_col_ord ) {
$ins_char_sth->execute($char_code);
}
$sql = "SELECT `$chunk_col` FROM $tmp_db_tbl "
. "WHERE `$chunk_col` BETWEEN ? AND ? "
. "ORDER BY `$chunk_col`";
MKDEBUG && _d($dbh, $sql);
my $sel_char_sth = $dbh->prepare($sql);
$sel_char_sth->execute($min_col, $max_col);
@chars = map { $_->[0] } @{ $sel_char_sth->fetchall_arrayref() };
$base = scalar @chars;
$sql = "DROP TABLE $tmp_db_tbl";
MKDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
MKDEBUG && _d("Base", $base, "chars:", @chars);
$sql = "SELECT MAX(LENGTH($chunk_col)) FROM $db_tbl ORDER BY `$chunk_col`";
MKDEBUG && _d($dbh, $sql);
$row = $dbh->selectrow_arrayref($sql);
my $max_col_len = $row->[0];
MKDEBUG && _d("Max column value:", $max_col, $max_col_len);
my $n_values;
for my $n_chars ( 1..$max_col_len ) {
$n_values = $base**$n_chars;
if ( $n_values >= $args{chunk_size} ) {
MKDEBUG && _d($n_chars, "chars in base", $base, "expresses",
$n_values, "values");
last;
}
}
my $n_chunks = $args{rows_in_range} / $args{chunk_size};
my $interval = floor($n_values / $n_chunks) || 1;
my $range_func = sub {
my ( $self, $dbh, $start, $interval, $max ) = @_;
my $start_char = $self->base_count(
count_to => $start,
base => $base,
symbols => \@chars,
);
my $end_char = $self->base_count(
count_to => min($max, $start + $interval),
base => $base,
symbols => \@chars,
);
return $start_char, $end_char;
};
return (
col => $q->quote($chunk_col),
start_point => 0,
end_point => $n_values,
interval => $interval,
range_func => $range_func,
);
}
sub get_first_chunkable_column {
my ( $self, %args ) = @_;
foreach my $arg ( qw(tbl_struct) ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($exact, @cols) = $self->find_chunk_columns(%args);
my $col = $cols[0]->{column};
my $idx = $cols[0]->{index};
my $wanted_col = $args{chunk_column};
my $wanted_idx = $args{chunk_index};
MKDEBUG && _d("Preferred chunk col/idx:", $wanted_col, $wanted_idx);
if ( $wanted_col && $wanted_idx ) {
foreach my $chunkable_col ( @cols ) {
if ( $wanted_col eq $chunkable_col->{column}
&& $wanted_idx eq $chunkable_col->{index} ) {
$col = $wanted_col;
$idx = $wanted_idx;
last;
}
}
}
elsif ( $wanted_col ) {
foreach my $chunkable_col ( @cols ) {
if ( $wanted_col eq $chunkable_col->{column} ) {
$col = $wanted_col;
$idx = $chunkable_col->{index};
last;
}
}
}
elsif ( $wanted_idx ) {
foreach my $chunkable_col ( @cols ) {
if ( $wanted_idx eq $chunkable_col->{index} ) {
$col = $chunkable_col->{column};
$idx = $wanted_idx;
last;
}
}
}
MKDEBUG && _d('First chunkable col/index:', $col, $idx);
return $col, $idx;
}
sub size_to_rows {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl chunk_size);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $tbl, $chunk_size) = @args{@required_args};
my $q = $self->{Quoter};
my $du = $self->{MySQLDump};
my ($n_rows, $avg_row_length);
my ( $num, $suffix ) = $chunk_size =~ m/^(\d+)([MGk])?$/;
if ( $suffix ) { # Convert to bytes.
$chunk_size = $suffix eq 'k' ? $num * 1_024
: $suffix eq 'M' ? $num * 1_024 * 1_024
: $num * 1_024 * 1_024 * 1_024;
}
elsif ( $num ) {
$n_rows = $num;
}
else {
die "Invalid chunk size $chunk_size; must be an integer "
. "with optional suffix kMG";
}
if ( $suffix || $args{avg_row_length} ) {
my ($status) = $du->get_table_status($dbh, $q, $db, $tbl);
$avg_row_length = $status->{avg_row_length};
if ( !defined $n_rows ) {
$n_rows = $avg_row_length ? ceil($chunk_size / $avg_row_length) : undef;
}
}
return $n_rows, $avg_row_length;
}
sub get_range_statistics {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl chunk_col tbl_struct);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $tbl, $col) = @args{@required_args};
my $where = $args{where};
my $q = $self->{Quoter};
my $col_type = $args{tbl_struct}->{type_for}->{$col};
my $col_is_numeric = $args{tbl_struct}->{is_numeric}->{$col};
my $db_tbl = $q->quote($db, $tbl);
$col = $q->quote($col);
my ($min, $max);
eval {
my $sql = "SELECT MIN($col), MAX($col) FROM $db_tbl"
. ($args{index_hint} ? " $args{index_hint}" : "")
. ($where ? " WHERE ($where)" : '');
MKDEBUG && _d($dbh, $sql);
($min, $max) = $dbh->selectrow_array($sql);
MKDEBUG && _d("Actual end points:", $min, $max);
($min, $max) = $self->get_valid_end_points(
%args,
dbh => $dbh,
db_tbl => $db_tbl,
col => $col,
col_type => $col_type,
min => $min,
max => $max,
);
MKDEBUG && _d("Valid end points:", $min, $max);
};
if ( $EVAL_ERROR ) {
die "Error getting min and max values for table $db_tbl "
. "on column $col: $EVAL_ERROR";
}
my $sql = "EXPLAIN SELECT * FROM $db_tbl"
. ($args{index_hint} ? " $args{index_hint}" : "")
. ($where ? " WHERE $where" : '');
MKDEBUG && _d($sql);
my $expl = $dbh->selectrow_hashref($sql);
return (
min => $min,
max => $max,
rows_in_range => $expl->{rows},
);
}
sub inject_chunks {
my ( $self, %args ) = @_;
foreach my $arg ( qw(database table chunks chunk_num query) ) {
die "I need a $arg argument" unless defined $args{$arg};
}
MKDEBUG && _d('Injecting chunk', $args{chunk_num});
my $query = $args{query};
my $comment = sprintf("/*%s.%s:%d/%d*/",
$args{database}, $args{table},
$args{chunk_num} + 1, scalar @{$args{chunks}});
$query =~ s!/\*PROGRESS_COMMENT\*/!$comment!;
my $where = "WHERE (" . $args{chunks}->[$args{chunk_num}] . ')';
if ( $args{where} && grep { $_ } @{$args{where}} ) {
$where .= " AND ("
. join(" AND ", map { "($_)" } grep { $_ } @{$args{where}} )
. ")";
}
my $db_tbl = $self->{Quoter}->quote(@args{qw(database table)});
my $index_hint = $args{index_hint} || '';
MKDEBUG && _d('Parameters:',
Dumper({WHERE => $where, DB_TBL => $db_tbl, INDEX_HINT => $index_hint}));
$query =~ s!/\*WHERE\*/! $where!;
$query =~ s!/\*DB_TBL\*/!$db_tbl!;
$query =~ s!/\*INDEX_HINT\*/! $index_hint!;
$query =~ s!/\*CHUNK_NUM\*/! $args{chunk_num} AS chunk_num,!;
return $query;
}
sub value_to_number {
my ( $self, %args ) = @_;
my @required_args = qw(column_type dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my $val = $args{value};
my ($col_type, $dbh) = @args{@required_args};
MKDEBUG && _d('Converting MySQL', $col_type, $val);
return unless defined $val; # value is NULL
my %mysql_conv_func_for = (
timestamp => 'UNIX_TIMESTAMP',
date => 'TO_DAYS',
time => 'TIME_TO_SEC',
datetime => 'TO_DAYS',
);
my $num;
if ( $col_type =~ m/(?:int|year|float|double|decimal)$/ ) {
$num = $val;
}
elsif ( $col_type =~ m/^(?:timestamp|date|time)$/ ) {
my $func = $mysql_conv_func_for{$col_type};
my $sql = "SELECT $func(?)";
MKDEBUG && _d($dbh, $sql, $val);
my $sth = $dbh->prepare($sql);
$sth->execute($val);
($num) = $sth->fetchrow_array();
}
elsif ( $col_type eq 'datetime' ) {
$num = $self->timestampdiff($dbh, $val);
}
else {
die "I don't know how to chunk $col_type\n";
}
MKDEBUG && _d('Converts to', $num);
return $num;
}
sub range_num {
my ( $self, $dbh, $start, $interval, $max ) = @_;
my $end = min($max, $start + $interval);
$start = sprintf('%.17f', $start) if $start =~ /e/;
$end = sprintf('%.17f', $end) if $end =~ /e/;
$start =~ s/\.(\d{5}).*$/.$1/;
$end =~ s/\.(\d{5}).*$/.$1/;
if ( $end > $start ) {
return ( $start, $end );
}
else {
die "Chunk size is too small: $end !> $start\n";
}
}
sub range_time {
my ( $self, $dbh, $start, $interval, $max ) = @_;
my $sql = "SELECT SEC_TO_TIME($start), SEC_TO_TIME(LEAST($max, $start + $interval))";
MKDEBUG && _d($sql);
return $dbh->selectrow_array($sql);
}
sub range_date {
my ( $self, $dbh, $start, $interval, $max ) = @_;
my $sql = "SELECT FROM_DAYS($start), FROM_DAYS(LEAST($max, $start + $interval))";
MKDEBUG && _d($sql);
return $dbh->selectrow_array($sql);
}
sub range_datetime {
my ( $self, $dbh, $start, $interval, $max ) = @_;
my $sql = "SELECT DATE_ADD('$self->{EPOCH}', INTERVAL $start SECOND), "
. "DATE_ADD('$self->{EPOCH}', INTERVAL LEAST($max, $start + $interval) SECOND)";
MKDEBUG && _d($sql);
return $dbh->selectrow_array($sql);
}
sub range_timestamp {
my ( $self, $dbh, $start, $interval, $max ) = @_;
my $sql = "SELECT FROM_UNIXTIME($start), FROM_UNIXTIME(LEAST($max, $start + $interval))";
MKDEBUG && _d($sql);
return $dbh->selectrow_array($sql);
}
sub timestampdiff {
my ( $self, $dbh, $time ) = @_;
my $sql = "SELECT (COALESCE(TO_DAYS('$time'), 0) * 86400 + TIME_TO_SEC('$time')) "
. "- TO_DAYS('$self->{EPOCH} 00:00:00') * 86400";
MKDEBUG && _d($sql);
my ( $diff ) = $dbh->selectrow_array($sql);
$sql = "SELECT DATE_ADD('$self->{EPOCH}', INTERVAL $diff SECOND)";
MKDEBUG && _d($sql);
my ( $check ) = $dbh->selectrow_array($sql);
die <<" EOF"
Incorrect datetime math: given $time, calculated $diff but checked to $check.
This could be due to a version of MySQL that overflows on large interval
values to DATE_ADD(), or the given datetime is not a valid date. If not,
please report this as a bug.
EOF
unless $check eq $time;
return $diff;
}
sub get_valid_end_points {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db_tbl col col_type);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db_tbl, $col, $col_type) = @args{@required_args};
my ($real_min, $real_max) = @args{qw(min max)};
my $err_fmt = "Error finding a valid %s value for table $db_tbl on "
. "column $col. The real %s value %s is invalid and "
. "no other valid values were found. Verify that the table "
. "has at least one valid value for this column"
. ($args{where} ? " where $args{where}." : ".");
my $valid_min = $real_min;
if ( defined $valid_min ) {
MKDEBUG && _d("Validating min end point:", $real_min);
$valid_min = $self->_get_valid_end_point(
%args,
val => $real_min,
endpoint => 'min',
);
die sprintf($err_fmt, 'minimum', 'minimum',
(defined $real_min ? $real_min : "NULL"))
unless defined $valid_min;
}
my $valid_max = $real_max;
if ( defined $valid_max ) {
MKDEBUG && _d("Validating max end point:", $real_min);
$valid_max = $self->_get_valid_end_point(
%args,
val => $real_max,
endpoint => 'max',
);
die sprintf($err_fmt, 'maximum', 'maximum',
(defined $real_max ? $real_max : "NULL"))
unless defined $valid_max;
}
return $valid_min, $valid_max;
}
sub _get_valid_end_point {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db_tbl col col_type);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db_tbl, $col, $col_type) = @args{@required_args};
my $val = $args{val};
return $val unless defined $val;
my $validate = $col_type =~ m/time|date/ ? \&_validate_temporal_value
: undef;
if ( !$validate ) {
MKDEBUG && _d("No validator for", $col_type, "values");
return $val;
}
return $val if defined $validate->($dbh, $val);
MKDEBUG && _d("Value is invalid, getting first valid value");
$val = $self->get_first_valid_value(
%args,
val => $val,
validate => $validate,
);
return $val;
}
sub get_first_valid_value {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db_tbl col validate endpoint);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db_tbl, $col, $validate, $endpoint) = @args{@required_args};
my $tries = defined $args{tries} ? $args{tries} : 5;
my $val = $args{val};
return unless defined $val;
my $cmp = $endpoint =~ m/min/i ? '>'
: $endpoint =~ m/max/i ? '<'
: die "Invalid endpoint arg: $endpoint";
my $sql = "SELECT $col FROM $db_tbl "
. ($args{index_hint} ? "$args{index_hint} " : "")
. "WHERE $col $cmp ? AND $col IS NOT NULL "
. ($args{where} ? "AND ($args{where}) " : "")
. "ORDER BY $col LIMIT 1";
MKDEBUG && _d($dbh, $sql);
my $sth = $dbh->prepare($sql);
my $last_val = $val;
while ( $tries-- ) {
$sth->execute($last_val);
my ($next_val) = $sth->fetchrow_array();
MKDEBUG && _d('Next value:', $next_val, '; tries left:', $tries);
if ( !defined $next_val ) {
MKDEBUG && _d('No more rows in table');
last;
}
if ( defined $validate->($dbh, $next_val) ) {
MKDEBUG && _d('First valid value:', $next_val);
$sth->finish();
return $next_val;
}
$last_val = $next_val;
}
$sth->finish();
$val = undef; # no valid value found
return $val;
}
sub _validate_temporal_value {
my ( $dbh, $val ) = @_;
my $sql = "SELECT IF(TIME_FORMAT(?,'%H:%i:%s')=?, TIME_TO_SEC(?), TO_DAYS(?))";
my $res;
eval {
MKDEBUG && _d($dbh, $sql, $val);
my $sth = $dbh->prepare($sql);
$sth->execute($val, $val, $val, $val);
($res) = $sth->fetchrow_array();
$sth->finish();
};
if ( $EVAL_ERROR ) {
MKDEBUG && _d($EVAL_ERROR);
}
return $res;
}
sub get_nonzero_value {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db_tbl col col_type);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db_tbl, $col, $col_type) = @args{@required_args};
my $tries = defined $args{tries} ? $args{tries} : 5;
my $val = $args{val};
my $is_nonzero = $col_type =~ m/time|date/ ? \&_validate_temporal_value
: sub { return $_[1]; };
if ( !$is_nonzero->($dbh, $val) ) { # quasi-double-negative, sorry
MKDEBUG && _d('Discarding zero value:', $val);
my $sql = "SELECT $col FROM $db_tbl "
. ($args{index_hint} ? "$args{index_hint} " : "")
. "WHERE $col > ? AND $col IS NOT NULL "
. ($args{where} ? "AND ($args{where}) " : '')
. "ORDER BY $col LIMIT 1";
MKDEBUG && _d($sql);
my $sth = $dbh->prepare($sql);
my $last_val = $val;
while ( $tries-- ) {
$sth->execute($last_val);
my ($next_val) = $sth->fetchrow_array();
if ( $is_nonzero->($dbh, $next_val) ) {
MKDEBUG && _d('First non-zero value:', $next_val);
$sth->finish();
return $next_val;
}
$last_val = $next_val;
}
$sth->finish();
$val = undef; # no non-zero value found
}
return $val;
}
sub base_count {
my ( $self, %args ) = @_;
my @required_args = qw(count_to base symbols);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($n, $base, $symbols) = @args{@required_args};
return $symbols->[0] if $n == 0;
my $highest_power = floor(log($n)/log($base));
if ( $highest_power == 0 ){
return $symbols->[$n];
}
my @base_powers;
for my $power ( 0..$highest_power ) {
push @base_powers, ($base**$power) || 1;
}
my @base_multiples;
foreach my $base_power ( reverse @base_powers ) {
my $multiples = floor($n / $base_power);
push @base_multiples, $multiples;
$n -= $multiples * $base_power;
}
return join('', map { $symbols->[$_] } @base_multiples);
}
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 TableChunker package
# ###########################################################################
# ###########################################################################
# Progress 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/Progress.pm
# t/lib/Progress.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Progress;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
foreach my $arg (qw(jobsize)) {
die "I need a $arg argument" unless defined $args{$arg};
}
if ( (!$args{report} || !$args{interval}) ) {
if ( $args{spec} && @{$args{spec}} == 2 ) {
@args{qw(report interval)} = @{$args{spec}};
}
else {
die "I need either report and interval arguments, or a spec";
}
}
my $name = $args{name} || "Progress";
$args{start} ||= time();
my $self;
$self = {
last_reported => $args{start},
fraction => 0, # How complete the job is
callback => sub {
my ($fraction, $elapsed, $remaining, $eta) = @_;
printf STDERR "$name: %3d%% %s remain\n",
$fraction * 100,
Transformers::secs_to_time($remaining),
Transformers::ts($eta);
},
%args,
};
return bless $self, $class;
}
sub validate_spec {
shift @_ if $_[0] eq 'Progress'; # Permit calling as Progress-> or Progress::
my ( $spec ) = @_;
if ( @$spec != 2 ) {
die "spec array requires a two-part argument\n";
}
if ( $spec->[0] !~ m/^(?:percentage|time|iterations)$/ ) {
die "spec array's first element must be one of "
. "percentage,time,iterations\n";
}
if ( $spec->[1] !~ m/^\d+$/ ) {
die "spec array's second element must be an integer\n";
}
}
sub set_callback {
my ( $self, $callback ) = @_;
$self->{callback} = $callback;
}
sub start {
my ( $self, $start ) = @_;
$self->{start} = $self->{last_reported} = $start || time();
}
sub update {
my ( $self, $callback, $now ) = @_;
my $jobsize = $self->{jobsize};
$now ||= time();
$self->{iterations}++; # How many updates have happened;
if ( $self->{report} eq 'time'
&& $self->{interval} > $now - $self->{last_reported}
) {
return;
}
elsif ( $self->{report} eq 'iterations'
&& ($self->{iterations} - 1) % $self->{interval} > 0
) {
return;
}
$self->{last_reported} = $now;
my $completed = $callback->();
$self->{updates}++; # How many times we have run the update callback
return if $completed > $jobsize;
my $fraction = $completed > 0 ? $completed / $jobsize : 0;
if ( $self->{report} eq 'percentage'
&& $self->fraction_modulo($self->{fraction})
>= $self->fraction_modulo($fraction)
) {
$self->{fraction} = $fraction;
return;
}
$self->{fraction} = $fraction;
my $elapsed = $now - $self->{start};
my $remaining = 0;
my $eta = $now;
if ( $completed > 0 && $completed <= $jobsize && $elapsed > 0 ) {
my $rate = $completed / $elapsed;
if ( $rate > 0 ) {
$remaining = ($jobsize - $completed) / $rate;
$eta = $now + int($remaining);
}
}
$self->{callback}->($fraction, $elapsed, $remaining, $eta, $completed);
}
sub fraction_modulo {
my ( $self, $num ) = @_;
$num *= 100; # Convert from fraction to percentage
return sprintf('%d',
sprintf('%d', $num / $self->{interval}) * $self->{interval});
}
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 Progress package
# ###########################################################################
# ###########################################################################
# OSCCaptureSync 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/OSCCaptureSync.pm
# t/lib/OSCCaptureSync.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package OSCCaptureSync;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
%args,
};
return bless $self, $class;
}
sub capture {
my ( $self, %args ) = @_;
my @required_args = qw(msg dbh db tbl tmp_tbl columns chunk_column);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($msg, $dbh) = @args{@required_args};
my @triggers = $self->_make_triggers(%args);
foreach my $sql ( @triggers ) {
$msg->($sql);
$dbh->do($sql) unless $args{print};
}
return;
}
sub _make_triggers {
my ( $self, %args ) = @_;
my @required_args = qw(db tbl tmp_tbl chunk_column columns);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($db, $tbl, $tmp_tbl, $chunk_column) = @args{@required_args};
my $old_table = "`$db`.`$tbl`";
my $new_table = "`$db`.`$tmp_tbl`";
my $new_values = join(', ', map { "NEW.$_" } @{$args{columns}});
my $columns = join(', ', @{$args{columns}});
my $delete_trigger = "CREATE TRIGGER mk_osc_del AFTER DELETE ON $old_table "
. "FOR EACH ROW "
. "DELETE IGNORE FROM $new_table "
. "WHERE $new_table.$chunk_column = OLD.$chunk_column";
my $insert_trigger = "CREATE TRIGGER mk_osc_ins AFTER INSERT ON $old_table "
. "FOR EACH ROW "
. "REPLACE INTO $new_table ($columns) "
. "VALUES($new_values)";
my $update_trigger = "CREATE TRIGGER mk_osc_upd AFTER UPDATE ON $old_table "
. "FOR EACH ROW "
. "REPLACE INTO $new_table ($columns) "
. "VALUES ($new_values)";
return $delete_trigger, $update_trigger, $insert_trigger;
}
sub sync {
my ( $self, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
return;
}
sub cleanup {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db msg);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $msg) = @args{@required_args};
foreach my $trigger ( qw(del ins upd) ) {
my $sql = "DROP TRIGGER IF EXISTS `$db`.`mk_osc_$trigger`";
$msg->($sql);
$dbh->do($sql) unless $args{print};
}
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 OSCCaptureSync package
# ###########################################################################
# ###########################################################################
# CopyRowsInsertSelect 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/CopyRowsInsertSelect.pm
# t/lib/CopyRowsInsertSelect.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package CopyRowsInsertSelect;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(Retry);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
%args,
};
return bless $self, $class;
}
sub copy {
my ( $self, %args ) = @_;
my @required_args = qw(dbh msg from_table to_table chunks columns);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $msg, $from_table, $to_table, $chunks) = @args{@required_args};
my $pr = $args{Progress};
my $sleep = $args{sleep};
my $columns = join(', ', @{$args{columns}});
my $n_chunks = @$chunks - 1;
for my $chunkno ( 0..$n_chunks ) {
if ( !$chunks->[$chunkno] ) {
warn "Chunk number ", ($chunkno + 1), "is undefined";
next;
}
my $sql = "INSERT IGNORE INTO $to_table ($columns) "
. "SELECT $columns FROM $from_table "
. "WHERE ($chunks->[$chunkno])"
. ($args{where} ? " AND ($args{where})" : "")
. ($args{engine_flags} ? " $args{engine_flags}" : "");
if ( $args{print} ) {
$msg->($sql);
}
else {
MKDEBUG && _d($dbh, $sql);
my $error;
$self->{Retry}->retry(
wait => sub { sleep 1; },
tries => 3,
try => sub {
my ( %args ) = @_;
eval {
$dbh->do($sql);
};
if ( $EVAL_ERROR ) {
MKDEBUG && _d($EVAL_ERROR);
if ( $EVAL_ERROR =~ m/Lock wait timeout exceeded/ ) {
$error = $EVAL_ERROR;
if ( $args{tryno} > 1 ) {
$msg->("Lock wait timeout exceeded; retrying $sql");
}
return;
}
die $EVAL_ERROR;
}
return 1;
},
on_failure => sub { die $error; },
);
}
$pr->update(sub { return $chunkno + 1; }) if $pr;
$sleep->($chunkno + 1) if $sleep && $chunkno < $n_chunks;
}
return;
}
sub cleanup {
my ( $self, %args ) = @_;
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 CopyRowsInsertSelect package
# ###########################################################################
# ###########################################################################
# Retry 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/Retry.pm
# t/lib/Retry.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Retry;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my $self = {
%args,
};
return bless $self, $class;
}
sub retry {
my ( $self, %args ) = @_;
my @required_args = qw(try wait);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my ($try, $wait) = @args{@required_args};
my $tries = $args{tries} || 3;
my $tryno = 0;
while ( ++$tryno <= $tries ) {
MKDEBUG && _d("Retry", $tryno, "of", $tries);
my $result;
eval {
$result = $try->(tryno=>$tryno);
};
if ( defined $result ) {
MKDEBUG && _d("Try code succeeded");
if ( my $on_success = $args{on_success} ) {
MKDEBUG && _d("Calling on_success code");
$on_success->(tryno=>$tryno, result=>$result);
}
return $result;
}
if ( $EVAL_ERROR ) {
MKDEBUG && _d("Try code died:", $EVAL_ERROR);
die $EVAL_ERROR unless $args{retry_on_die};
}
if ( $tryno < $tries ) {
MKDEBUG && _d("Try code failed, calling wait code");
$wait->(tryno=>$tryno);
}
}
MKDEBUG && _d("Try code did not succeed");
if ( my $on_failure = $args{on_failure} ) {
MKDEBUG && _d("Calling on_failure code");
$on_failure->();
}
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 Retry 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_online_schema_change;
use English qw(-no_match_vars);
use Time::HiRes qw(sleep);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
Transformers->import qw(ts);
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
my $quiet = 0; # for msg()
sub main {
@ARGV = @_; # set global ARGV for this package
my $vp = new VersionParser();
my $q = new Quoter();
my $tp = new TableParser(Quoter => $q);
my $du = new MySQLDump();
my $chunker = new TableChunker(Quoter => $q, MySQLDump => $du);
# ########################################################################
# Get configuration information.
# ########################################################################
my $o = new OptionParser();
$o->get_specs();
$o->get_opts();
my $dp = $o->DSNParser();
$dp->prop('set-vars', $o->get('set-vars'));
$quiet = $o->get('quiet'); # for msg()
my ($dsn, $db, $tbl);
$dsn = shift @ARGV;
if ( !$dsn ) {
$o->save_error('A DSN with a t part must be specified');
}
else {
$dsn = $dp->parse($dsn, $dp->parse_options($o));
if ( !$dsn->{t} ) {
$o->save_error('The DSN must specify a t (table) part');
}
else {
($db, $tbl) = $q->split_unquote($dsn->{t} || "", $dsn->{D} || "");
}
}
my $rename_fk_method = lc $o->get('update-foreign-keys-method');
if ( ($rename_fk_method || '') eq 'drop_old_table' ) {
$o->set('rename-tables', 0);
$o->set('drop-old-table', 0),
}
if ( !$o->get('help') ) {
if ( @ARGV ) {
$o->save_error('Specify only one DSN on the command line');
}
if ( !$db ) {
$o->save_error("No database was specified in the DSN or by "
. "--database (-D)");
}
if ( $tbl && $tbl eq ($o->get('tmp-table') || "") ) {
$o->save_error("--tmp-table cannot be the same as the table");
}
if ( $o->get('progress') ) {
eval { Progress->validate_spec($o->get('progress')) };
if ( $EVAL_ERROR ) {
chomp $EVAL_ERROR;
$o->save_error("--progress $EVAL_ERROR");
}
}
if ( $o->get('child-tables') && !$o->get('update-foreign-keys-method') ) {
$o->save_error("--child-tables requires --update-foreign-keys-method");
}
if ( $rename_fk_method
&& $rename_fk_method ne 'rebuild_constraints'
&& $rename_fk_method ne 'drop_old_table' ) {
$o->save_error("Invalid --update-foreign-keys-method value");
}
}
$o->usage_or_errors();
msg("$PROGRAM_NAME started");
my $exit_status = 0;
# ########################################################################
# Connect to MySQL.
# ########################################################################
my $dbh = get_cxn(
dsn => $dsn,
DSNParser => $dp,
OptionParser => $o,
AutoCommit => 1,
);
msg("USE `$db`");
$dbh->do("USE `$db`");
# ########################################################################
# Daemonize only after (potentially) asking for passwords for --ask-pass.
# ########################################################################
my $daemon;
if ( $o->get('pid') ) {
# We're not daemoninzing, it just handles PID stuff.
$daemon = new Daemon(o=>$o);
$daemon->make_PID_file();
}
# ########################################################################
# Setup/init some vars.
# ########################################################################
my $tmp_tbl = $o->get('tmp-table') || "__tmp_$tbl";
my $old_tbl = "__old_$tbl"; # what tbl becomes after swapped with tmp tbl
my %tables = (
db => $db,
tbl => $tbl,
tmp_tbl => $tmp_tbl,
old_tbl => $old_tbl,
);
msg("Alter table $tbl using temporary table $tmp_tbl");
my %common_modules = (
OptionParser => $o,
DSNParser => $dp,
Quoter => $q,
TableParser => $tp,
TableChunker => $chunker,
MySQLDump => $du,
VersionParser => $vp,
);
# ########################################################################
# Create the capture-sync and copy-rows plugins. Currently, we just have
# one method for each.
# ########################################################################
my $capture_sync = new OSCCaptureSync();
my $copy_rows = new CopyRowsInsertSelect(Retry => new Retry());
# More values are added later. These are the minimum need to do --cleanup.
my %plugin_args = (
dbh => $dbh,
msg => \&msg, # so plugin can talk back to user
print => $o->get('print'),
%tables,
%common_modules,
);
if ( my $sleep_time = $o->get('sleep') ) {
MKDEBUG && _d("Sleep time:", $sleep_time);
$plugin_args{sleep} = sub {
my ( $chunkno ) = @_;
MKDEBUG && _d("Sleeping after chunk", $chunkno);
sleep($sleep_time);
};
}
# ########################################################################
# Just cleanup and exit.
# ########################################################################
if ( $o->get('cleanup-and-exit') ) {
msg("Calling " . (ref $copy_rows). "::cleanup()");
$copy_rows->cleanup(%plugin_args);
msg("Calling " . (ref $capture_sync) . "::cleanup()");
$capture_sync->cleanup(%plugin_args);
msg("$PROGRAM_NAME ending for --cleanup-and-exit");
return 0;
}
# ########################################################################
# Check that table can be altered.
# ########################################################################
my %tbl_info;
eval {
%tbl_info = check_tables(%plugin_args);
};
if ( $EVAL_ERROR ) {
chomp $EVAL_ERROR;
msg("Table $tbl cannot be altered: $EVAL_ERROR");
return 1;
}
@plugin_args{keys %tbl_info} = values %tbl_info;
msg("Table $tbl can be altered");
msg("Chunk column $plugin_args{chunk_column}, index $plugin_args{chunk_index}");
if ( $o->get('check-tables-and-exit') ) {
msg("$PROGRAM_NAME ending for --check-tables-and-exit");
return 0;
}
# #####################################################################
# Chunk the table. If the checks pass, then this shouldn't fail.
# #####################################################################
my %range_stats = $chunker->get_range_statistics(
dbh => $dbh,
db => $db,
tbl => $tbl,
chunk_col => $plugin_args{chunk_column},
tbl_struct => $plugin_args{tbl_struct},
);
my @chunks = $chunker->calculate_chunks(
dbh => $dbh,
db => $db,
tbl => $tbl,
chunk_col => $plugin_args{chunk_column},
tbl_struct => $plugin_args{tbl_struct},
chunk_size => $o->get('chunk-size'),
%range_stats,
);
$plugin_args{chunks} = \@chunks;
$plugin_args{Progress} = new Progress(
jobsize => scalar @chunks,
spec => $o->get('progress'),
name => "Copying rows",
);
msg("Chunked table $tbl into " . scalar @chunks . " chunks");
# #####################################################################
# Get child tables if necessary.
# #####################################################################
my @child_tables;
if ( my $child_tables = $o->get('child-tables') ) {
if ( lc $child_tables eq 'auto_detect' ) {
msg("Auto-detecting child tables of $tbl");
@child_tables = get_child_tables(%plugin_args);
msg("Child tables of $tables{old_table}: "
. (@child_tables ? join(', ', @child_tables) : "(none)"));
}
else {
@child_tables = split(',', $child_tables);
msg("User-specified child tables: " . join(', ', @child_tables));
}
}
# #####################################################################
# Do the online alter.
# #####################################################################
msg("Starting online schema change");
eval {
my $sql = "";
# #####################################################################
# Create and alter the new table.
# #####################################################################
if ( $o->get('create-tmp-table') ) {
$sql = "CREATE TABLE `$db`.`$tmp_tbl` LIKE `$db`.`$tbl`";
msg($sql);
$dbh->do($sql) unless $o->get('print');
}
if ( my $alter = $o->get('alter') ) {
my @stmts;
if ( -f $alter && -r $alter ) {
msg("Reading ALTER TABLE statements from file $alter");
open my $fh, '<', $alter or die "Cannot open $alter: $OS_ERROR";
@stmts = <$fh>;
close $fh;
}
else {
@stmts = split(';', $alter);
}
foreach my $stmt ( @stmts ) {
$sql = "ALTER TABLE `$db`.`$tmp_tbl` $stmt";
msg($sql);
$dbh->do($sql) unless $o->get('print');
}
}
# #####################################################################
# Determine what columns the two tables have in common.
# #####################################################################
my @columns;
# If --print is in effect, then chances are the new table wasn't
# created above, so we can't get it's struct.
# TODO: check if the new table exists because user might have created
# it manually.
if ( !$o->get('print') ) {
my $tmp_tbl_struct = $tp->parse(
$du->get_create_table($dbh, $q, $db, $tmp_tbl));
@columns = intersection([
$plugin_args{tbl_struct}->{is_col},
$tmp_tbl_struct->{is_col},
]);
# Order columns according to new table because people like/expect
# to see things in a certain order (this has been an issue before).
# This just matters to us; does't make a difference to MySQL.
my $col_posn = $plugin_args{tbl_struct}->{col_posn};
@columns = sort { $col_posn->{$a} <=> $col_posn->{$b} } @columns;
msg("Shared columns: " . join(', ', @columns));
}
$plugin_args{columns} = \@columns;
# #####################################################################
# Start capturing changes to the new table.
# #####################################################################
msg("Calling " . (ref $capture_sync) . "::capture()");
$capture_sync->capture(%plugin_args);
# #####################################################################
# Copy rows from new table to old table.
# #####################################################################
msg("Calling " . (ref $copy_rows) . "::copy()");
$copy_rows->copy(
from_table => $q->quote($db, $tbl),
to_table => $q->quote($db, $tmp_tbl),
%plugin_args
);
# #####################################################################
# Sync tables.
# #####################################################################
msg("Calling " . (ref $capture_sync) . "::sync()");
$capture_sync->sync(%plugin_args);
# #####################################################################
# Rename tables.
# #####################################################################
if ( $o->get('rename-tables') ) {
msg("Renaming tables");
$sql = "RENAME TABLE `$db`.`$tbl` TO `$db`.`$old_tbl`,"
. " `$db`.`$tmp_tbl` TO `$db`.`$tbl`";
msg($sql);
$dbh->do($sql) unless $o->get('print');
msg("Original table $tbl renamed to $old_tbl");
}
# #####################################################################
# Update foreign key constraints if there are child tables.
# #####################################################################
if ( @child_tables ) {
msg("Renaming foreign key constraints in child table");
if ( $rename_fk_method eq 'rebuild_constraints' ) {
update_foreign_key_constraints(
child_tables => \@child_tables,
%plugin_args,
);
}
elsif ( $rename_fk_method eq 'drop_old_table' ) {
$sql = "SET foreign_key_checks=0";
msg($sql);
$dbh->do($sql) unless $o->get('print');
$sql = "DROP TABLE `$db`.`$tbl`";
msg($sql);
$dbh->do($sql) unless $o->get('print');
$sql = "RENAME TABLE `$db`.`$tmp_tbl` TO `$db`.`$tbl`";
msg($sql);
$dbh->do($sql) unless $o->get('print');
}
else {
die "Invalid --update-foreign-keys-method value: $rename_fk_method";
}
}
# #####################################################################
# Cleanup.
# #####################################################################
msg("Calling " . (ref $copy_rows). "::cleanup()");
$copy_rows->cleanup(%plugin_args);
msg("Calling " . (ref $capture_sync) . "::cleanup()");
$capture_sync->cleanup(%plugin_args);
if ( $o->get('rename-tables') && $o->get('drop-old-table') ) {
$sql = "DROP TABLE `$db`.`$old_tbl`";
msg($sql);
$dbh->do($sql) unless $o->get('print');
}
};
if ( $EVAL_ERROR ) {
warn "An error occurred:\n\n$EVAL_ERROR\n"
. "Some triggers, temp tables, etc. may not have been removed. "
. "Run with --cleanup-and-exit to remove these items.\n";
$exit_status = 1;
}
msg("$PROGRAM_NAME ended, exit status $exit_status");
return $exit_status;
}
# ############################################################################
# Subroutines.
# ############################################################################
sub check_tables {
my ( %args ) = @_;
my @required_args = qw(dbh db tbl tmp_tbl old_tbl VersionParser Quoter TableParser OptionParser TableChunker MySQLDump);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $tbl, $tmp_tbl, $old_tbl, $o, $tp)
= @args{qw(dbh db tbl tmp_tbl old_tbl OptionParser TableParser)};
msg("Checking if table $tbl can be altered");
my %tbl_info;
my $sql = "";
# ########################################################################
# Check MySQL.
# ########################################################################
# Although triggers were introduced in 5.0.2, "Prior to MySQL 5.0.10,
# triggers cannot contain direct references to tables by name."
if ( !$args{VersionParser}->version_ge($dbh, '5.0.10') ) {
die "This tool requires MySQL 5.0.10 or newer\n";
}
# ########################################################################
# Check the (original) table.
# ########################################################################
# The table must exist of course.
if ( !$tp->check_table(dbh=>$dbh, db=>$db, tbl=>$tbl) ) {
die "Table $db.$tbl does not exist\n";
}
# There cannot be any triggers on the table.
$sql = "SHOW TRIGGERS FROM `$db` LIKE '$tbl'";
msg($sql);
my $triggers = $dbh->selectall_arrayref($sql);
if ( $triggers && @$triggers ) {
die "Table $db.$tbl has triggers. This tool needs to create "
. "its own triggers, so the table cannot already have triggers.\n";
}
# For now, we require that the old table has an exact-chunkable
# column (i.e. unique single-column).
$tbl_info{tbl_struct} = $tp->parse(
$args{MySQLDump}->get_create_table($dbh, $args{Quoter}, $db, $tbl));
my ($exact, @chunkable_cols) = $args{TableChunker}->find_chunk_columns(
tbl_struct => $tbl_info{tbl_struct},
exact => 1,
);
if ( !$exact || !@chunkable_cols ) {
die "Table $db.$tbl cannot be chunked because it does not have "
. "a unique, single-column index\n";
}
$tbl_info{chunk_column} = $chunkable_cols[0]->{column};
$tbl_info{chunk_index} = $chunkable_cols[0]->{index};
# ########################################################################
# Check the tmp table.
# ########################################################################
# The tmp table should not exist if we're supposed to create it.
# Else, if user specifies --no-create-tmp-table, they should ensure
# that it exists.
if ( $o->get('create-tmp-table')
&& $tp->check_table(dbh=>$dbh, db=>$db, tbl=>$tmp_tbl) ) {
die "Temporary table $db.$tmp_tbl exists which will prevent "
. "--create-tmp-table from creating the temporary table.\n";
}
# ########################################################################
# Check the old table.
# ########################################################################
# If we're going to rename the tables, which we do by default, then
# the old table cannot already exist.
if ( $o->get('rename-tables')
&& $tp->check_table(dbh=>$dbh, db=>$db, tbl=>$old_tbl) ) {
die "Table $db.$old_tbl exists which will prevent $db.$tbl "
. "from being renamed to it. Table $db.$old_tbl could be from "
. "a previous run that failed. See --drop-old-table for more "
. "information.\n";
}
return %tbl_info;
}
sub get_child_tables {
my ( %args ) = @_;
my @required_args = qw(dbh db tbl Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $tbl, $q) = @args{@required_args};
my $sql = "SELECT table_name "
. "FROM information_schema.key_column_usage "
. "WHERE constraint_schema='$db' AND referenced_table_name='$tbl'";
MKDEBUG && _d($dbh, $sql);
my $child_tables;
eval {
$child_tables = $dbh->selectall_arrayref($sql);
};
if ( $EVAL_ERROR ) {
die "Error executing query to check $tbl for child tables.\n\n"
. "Query: $sql\n\n"
. "Error: $EVAL_ERROR"
}
MKDEBUG && _d("Child tables:", join(', ', map { $_->[0] } @$child_tables));
return map { $_->[0] } @$child_tables;
}
sub update_foreign_key_constraints {
my ( %args ) = @_;
my @required_args = qw(msg dbh db tbl old_tbl child_tables Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($msg, $dbh, $db, $tbl, $old_tbl, $child_tables, $q)
= @args{@required_args};
my $constraint = qr/^\s+(CONSTRAINT.+?REFERENCES `$old_tbl`.+)$/mo;
CHILD_TABLE:
foreach my $child_table ( @$child_tables ) {
my $sql = "SHOW CREATE TABLE `$db`.`$child_table`";
MKDEBUG && _d($dbh, $sql);
$msg->($sql);
my $table_def;
eval {
$table_def = $dbh->selectrow_arrayref($sql)->[1];
};
if ( $EVAL_ERROR ) {
warn "Skipping child table $child_table: $EVAL_ERROR";
next CHILD_TABLE;
}
my @constraints = $table_def =~ m/$constraint/g;
if ( !@constraints ) {
warn "Child table `$child_table` does not have any foreign key "
. "constraints referencing $old_tbl";
next CHILD_TABLE;
}
foreach my $constraint ( @constraints ) {
my ($fk_symbol) = $constraint =~ m/CONSTRAINT\s+(\S+)/;
$sql = "ALTER TABLE `$db`.`$child_table` DROP FOREIGN KEY $fk_symbol";
$msg->($sql);
$dbh->do($sql) unless $args{print};
$constraint =~ s/REFERENCES `$old_tbl`/REFERENCES `$tbl`/o;
$sql = "ALTER TABLE `$db`.`$child_table` ADD $constraint";
$msg->($sql);
$dbh->do($sql) unless $args{print};
}
}
return;
}
sub intersection {
my ( $hashes ) = @_;
my %keys = map { $_ => 1 } keys %{$hashes->[0]};
my $n_hashes = (scalar @$hashes) - 1;
my @isect = grep { $keys{$_} } map { keys %{$hashes->[$_]} } 1..$n_hashes;
return @isect;
}
sub get_cxn {
my ( %args ) = @_;
my ($dsn, $ac, $dp, $o) = @args{qw(dsn AutoCommit DSNParser OptionParser)};
if ( $o->get('ask-pass') ) {
$dsn->{p} = OptionParser::prompt_noecho("Enter password: ");
}
my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn), {AutoCommit => $ac});
$dbh->do('SET SQL_LOG_BIN=0') unless $o->get('bin-log');
$dbh->do('SET FOREIGN_KEY_CHECKS=0') unless $o->get('foreign-key-checks');
return $dbh;
}
sub msg {
my ( $msg ) = @_;
chomp $msg;
print '# ', ts(time), " $msg\n" unless $quiet;
MKDEBUG && _d($msg);
return;
}
# Only for tests which may not call main().
sub __set_quiet {
$quiet = $_[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";
}
# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }
1; # Because this is a module as well as a script.
# ############################################################################
# Documentation
# ############################################################################
=pod
=head1 NAME
pt-online-schema-change - Perform online, non-blocking table schema changes.
=head1 SYNOPSIS
Usage: pt-online-schema-change [OPTION...] DSN
pt-online-schema-change performs online, non-blocking schema changes to a table.
The table to change must be specified in the DSN C<t> part, like C<t=my_table>.
The table can be database-qualified, or the database can be specified with the
L<"--database"> option.
Change the table's engine to InnoDB:
pt-online-schema-change \
h=127.1,t=db.tbl \
--alter "ENGINE=InnoDB" \
--drop-tmp-table
Rebuild but do not alter the table, and keep the temporary table:
pt-online-schema-change h=127.1,t=tbl --database db
Add column to parent table, update child table foreign key constraints:
pt-online-schema-change \
h=127.1,D=db,t=parent \
--alter "ADD COLUMN (foo INT)" \
--child-tables child1,child2 \
--update-foreign-keys-method drop_tmp_table
=head1 RISKS
The following section is included to inform users about the potential risks,
whether known or unknown, of using this tool. The two main categories of risks
are those created by the nature of the tool (e.g. read-only tools vs. read-write
tools) and those created by bugs.
pt-online-schema-change reads, writes, alters and drops tables. Although
it is tested, do not use it in production until you have thoroughly tested it
in your environment!
This tool has not been tested with replication; it may break replication.
See L<"REPLICATION">.
At the time of this release there are no known bugs that pose a serious risk.
The authoritative source for updated information is always the online issue
tracking system. Issues that affect this tool will be marked as such. You can
see a list of such issues at the following URL:
L<http://www.percona.com/bugs/pt-online-schema-change>.
See also L<"BUGS"> for more information on filing bugs and getting help.
=head1 DESCRIPTION
pt-online-schema-change performs online, non-blocking schema changes to tables.
Only one table can be altered at a time because triggers are used to capture
and synchronize changes between the table and the temporary table that
will take its place once it has been altered. Since triggers are used, this
tool only works with MySQL 5.0.2 and newer.
The table to alter is specified by the DSN C<t> part on the command line,
as shown in the L<"SYNOPSIS"> examples. A database must also be specified
either by the DSN C<D> part or by the L<"--database"> option.
If you're using replication, read L<"REPLICATION"> or else you may break
replication. Performing an online schema change in a replication environment
requires extra planning and care.
In brief, this tool works by creating a temporary table which is a copy of
the original table (the one being altered). (The temporary table is not
created like C<CREATE TEMPORARY TABLE>; we call it temporary because it
ultimately replaces the original table.) The temporary table is altered,
then triggers are defined on the original table to capture changes made on
it and apply them to the temporary table. This keeps the two tables in
sync. Then all rows are copied from the original table to the temporary
table; this part can take awhile. When done copying rows, the two tables
are swapped by using C<RENAME TABLE>. At this point there are two copies
of the table: the old table which used to be the original table, and the
new table which used to be the temporary table but now has the same name
as the original table. If L<"--drop-old-table"> is specified, then the
old table is dropped.
For example, if you alter table C<foo>, the tool will create table
C<__tmp_foo>, alter it, define triggers on C<foo>, and then copy rows
from C<foo> to C<__tmp_foo>. Once all rows are copied, C<foo> is renamed
to C<__old_foo> and C<__tmp_foo> is renamed to C<foo>.
If L<"--drop-old-table"> is specified, then C<__old_foo> is dropped.
The tool preforms the following steps:
1. Sanity checks
2. Chunking
3. Online schema change
The first two steps cannot be skipped. The sanity checks help ensure that
running the tool will work and not encounter problems half way through the
whole process. Chunk is required during the third step when rows from the
old table are copied to the new table. Currently, only table with a
single-column unique index can be chunked. If there is any problem in these
two steps, the tool will die.
Most of the tool's work is done in the third step which has 6 phases:
1. Create and alter temporary table
2. Capture changes from the table to the temporary table
3. Copy rows from the table to the temporary table
4. Synchronize the table and the temporary table
5. Swap/rename the table and the temporary table
6. Cleanup
There are several ways to accomplish an online schema change which differ
in how changes are captured and synced (phases 2 and 4), how rows are copied
(phase 3), and how the tables are swapped (phase 5). Currently, this tool
employs synchronous triggers (Shlomi's method), C<INSERT-SELECT>, and
C<RENAME TABLE> respectively for these phases.
Here are options related to each phase:
1. --[no]create-tmp-table, --alter, --tmp-table
2. (none)
3. --chunk-size, --sleep
4. (none)
5. --[no]rename-tables
6. --drop-old-table
Options L<"--check-tables-and-exit"> and L<"--print"> are helpful to see what
the tool might do before actually doing it.
=head1 REPLICATION
In brief: update slaves first if columns are added or removed. Certain
ALTER changes like ENGINE may not affect replication.
=head1 OUTPUT
Output to STDOUT is very verbose and should tell you everything that the
tool is doing. Warnings, errors, and L<"--progress"> are printed to STDERR.
=head1 OPTIONS
This tool accepts additional command-line arguments. Refer to the
L<"SYNOPSIS"> and usage information for details.
=over
=item --alter
type: string
Semicolon-separated list of C<ALTER TABLE> statements to apply to the new table.
The statements should not contain C<ALTER TABLE>, just what would follow that
clause. For example, if you want to C<ALTER TABLE ENGINE=InnoDB>, the value
would be C<ENGINE=InnoDB>.
The value can also be a filename which contains statements, one per line
with no blank lines and no trailing semicolons. Each statement will be
applied in the order it appears in the file.
=item --ask-pass
Prompt for a password when connecting to MySQL.
=item --bin-log
Allow binary logging (C<SET SQL_LOG_BIN=1>). By default binary logging is
turned off because in most cases the L<"--tmp-table"> does not need to
be replicated. Also, performing an online schema change in a replication
environment requires careful planning else replication may be broken;
see L<"REPLICATION">.
=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 --check-tables-and-exit
Check that the table can be altered then exit; do not alter the table.
If you just want to see that the tool can/will work for the given table,
specify this option. Even if all checks pass, the tool may still encounter
problems if, for example, one of the L<"--alter"> statements uses
incorrect syntax.
=item --child-tables
type: string
Foreign key constraints in these (child) tables reference the table.
If the table being altered is a parent to tables which reference it with
foreign key constraints, you must specify those child tables with this option
so that the tool will update the foreign key constraints after renaming
tables. The list of child tables is comma-separated, not quoted, and not
database-qualified (the database is assumed to be the same as the table)
If you specify a table that doesn't exist, it is ignored.
Or you can specify just C<auto_detect> and the tool will query the
C<INFORMATION_SCHEMA> to auto-detect any foreign key constraints on the table.
When specifying this option, you must also specify
L<"--update-foreign-keys-method">.
=item --chunk-size
type: string; default: 1000
Number of rows or data size per chunk. Data sizes are specified with a
suffix of k=kibibytes, M=mebibytes, G=gibibytes. Data sizes are converted
to a number of rows by dividing by the average row length.
=item --cleanup-and-exit
Cleanup and exit; do not alter the table. If a previous run fails, you
may need to use this option to remove any temporary tables, triggers,
outfiles, etc. that where left behind before another run will succeed.
=item --config
type: Array
Read this comma-separated list of config files; if specified, this must be the
first option on the command line.
=item --[no]create-tmp-table
default: yes
Create the L<"--tmp-table"> with C<CREATE TABLE LIKE>. The temporary table
to which the L<"--alter"> statements are applied is automatically created
by default with the name C<__tmp_TABLE> where C<TABLE> is the original table
specified by the DSN on the command line. If you want to create the temporary
table manually before running this tool, then you must specify
C<--no-create-tmp-table> B<and> L<"--tmp-table"> so the tool will use your
temporary table.
=item --database
short form: -D; type: string
Database of the table. You can also specify the database with the C<D> part
of the DSN given on the command line.
=item --defaults-file
short form: -F; type: string
Only read mysql options from the given file. You must give an absolute
pathname.
=item --drop-old-table
Drop the original table after it's swapped with the L<"--tmp-table">.
After the original table is renamed/swapped with the L<"--tmp-table">
it becomes the "old table". By default, the old table is not dropped
because if there are problems with the "new table" (the temporary table
swapped for the original table), then the old table can be restored.
If altering a table with foreign key constraints, you may need to specify
this option depending on which L<"--update-foreign-keys-method"> you choose.
=item --[no]foreign-key-checks
default: yes
Enforce foreign key checks (FOREIGN_KEY_CHECKS=1).
=item --help
Show help and exit.
=item --host
short form: -h; type: string
Connect to host.
=item --password
short form: -p; type: string
Password to use when connecting.
=item --pid
type: string
Create the given PID file. The file contains the process ID of the tool's
instance. The PID file is removed when the tool exits. The tool checks for
the existence of the PID file when starting; if it exists and the process with
the matching PID exists, the tool exits.
=item --port
short form: -P; type: int
Port number to use for connection.
=item --print
Print SQL statements to STDOUT instead of executing them. Specifying this
option allows you to see most of the statements that the tool would execute.
=item --progress
type: array; default: time,30
Print progress reports to STDERR while copying rows.
The value is a comma-separated list with two parts. The first part can be
percentage, time, or iterations; the second part specifies how often an update
should be printed, in percentage, seconds, or number of iterations.
=item --quiet
short form: -q
Do not print messages to STDOUT. Errors and warnings are still printed to
STDERR.
=item --[no]rename-tables
default: yes
Rename/swap the original table and the L<"--tmp-table">. This option
essentially completes the online schema change process by making the
temporary table with the new schema take the place of the original table.
The original tables becomes the "old table" and is dropped if
L<"--drop-old-table"> is specified.
=item --set-vars
type: string; default: wait_timeout=10000
Set these MySQL variables. Immediately after connecting to MySQL, this string
will be appended to SET and executed.
=item --sleep
type: float; default: 0
How long to sleep between chunks while copying rows. The time has micro-second
precision, so you can specify fractions of seconds like C<0.1>.
=item --socket
short form: -S; type: string
Socket file to use for connection.
=item --tmp-table
type: string
Temporary table if C<--no-create-tmp-table> is specified. If you specify
C<--no-create-tmp-table>, then you must also specify this option to tell
the tool which table to use as the temporary table. The temporary table
and the original table are renamed/swapped unless C<--no-rename-tables> is
specified.
The default behavior, when this option is not specified and
C<--[no]create-tmp-tble> is true, is to create a temporary table named
C<__tmp_TABLE> where C<TABLE> is the original table specified by the DSN
on the command line.
=item --update-foreign-keys-method
type: string
Method for updating foreign key constraints in L<"--child-tables">. If
L<"--child-tables"> is specified, the tool will need to ensure that foreign
key constraints in those tables continue to reference the original table
after it is renamed and/or dropped. This is necessary because when a parent
table is renamed, MySQL automatically updates all child table
foreign key constraints that reference the renamed table so that the rename
does not break foreign key constraints. This poses a problem for this tool.
For example: if the table being altered is C<foo>, then C<foo> is renamed
to C<__old_foo> when it is swapped with the L<"--tmp-table">.
Any foreign key references to C<foo> before it is swapped/renamed are renamed
automatically by MySQL to C<__old_foo>. We do not want this; we want those
foreign key references to continue to reference C<foo>.
There are currently two methods to solve this problem:
=over
=item rebuild_constraints
Drop and re-add child table foreign key constraints to reference the new table.
(The new table is the temporary table after being renamed/swapped. To MySQL
it's a new table because it does not know that it's a copy of the original
table). This method parses foreign key constraints referencing the original
table from all child tables, drops them, then re-adds them referencing the
new table.
This method uses C<ALTER TABLE> which can by slow and blocking, but it is
safer because the old table does not need to be dropped. So if there's a
problem with the new table and L<"--drop-old-table"> was not specified,
then the original table can be restored.
=item drop_old_table
Disable foreign key checks (FOREIGN_KEY_CHECKS=0) then drop the original table.
This method bypasses MySQL's auto-renaming feature by disabling foreign key
checks, dropping the original table, then renaming the temporary table with
the same name. Foreign key checks must be disabled to drop table because it is
referenced by foreign key constraints. Since the original table is not renamed,
MySQL does not auto-rename references to it. Then the temporary table is
renamed to the same name so child table references are maintained.
So this method requires L<"--drop-old-table">.
This method is faster and does not block, but it is less safe for two reasons.
One, for a very short time (between dropping the original table and renaming the
temporary table) the child tables reference a non-existent table. Two, more
importantly, if for some reason the temporary table was not copied correctly,
didn't capture all changes, etc., the original table cannot be recovered
because it was dropped.
=back
=item --user
short form: -u; type: string
User for login if not current user.
=item --version
Show version and exit.
=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
Database for the old and new table.
=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.
=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 * t
dsn: table; copy: no
Table to alter.
=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-online-schema-change ... > 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-online-schema-change>.
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
=head1 ACKNOWLEDGMENTS
The "online schema change" concept was first implemented by Shlomi Noach
in his tool C<oak-online-alter-table>, part of
L<http://code.google.com/p/openarkkit/>. Then engineers at Facebook built
their version called C<OnlineSchemaChange.php> as explained by their blog
post: L<http://tinyurl.com/32zeb86>. Searching for "online schema change"
will return other relevant pages about this concept.
This implementation, C<pt-online-schema-change>, is a hybrid of Shlomi's
and Facebook's approach. Shlomi's code is a full-featured tool with command
line options, documentation, etc., but its continued development/support is
not assured. Facebook's tool has certain technical advantages, but it's not
a full-featured tool; it's more a custom job by Facebook for Facebook. And
neither of those tools is tested. C<pt-online-schema-change> is a
full-featured, tested tool with stable development and support.
This tool was made possible by a generous client of Percona Inc.
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools developed by Percona for MySQL support and consulting. Percona Toolkit
was forked from two projects in June, 2011: Maatkit and Aspersa. Those
projects were created by Baron Schwartz and developed primarily by him and
Daniel Nichter, both of whom are employed by Percona. Visit
L<http://www.percona.com/software/> for more software developed by Percona.
=head1 COPYRIGHT, LICENSE, AND WARRANTY
This program is copyright 2011 Percona Inc.
Feedback and improvements are welcome.
THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
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-online-schema-change 0.9.5
=cut
Reference in New Issue View Git Blame Copy Permalink