mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-07 21:09:14 +00:00
4276 lines
127 KiB
Perl
Executable File
4276 lines
127 KiB
Perl
Executable File
#!/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 PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
# ###########################################################################
|
|
# 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 PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
sub new {
|
|
my ( $class ) = @_;
|
|
bless {}, $class;
|
|
}
|
|
|
|
sub parse {
|
|
my ( $self, $str ) = @_;
|
|
my $result = sprintf('%03d%03d%03d', $str =~ m/(\d+)/g);
|
|
PTDEBUG && _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;
|
|
PTDEBUG && _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 ) {
|
|
PTDEBUG && _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
|
|
}
|
|
}
|
|
|
|
PTDEBUG && _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
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# 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 PTDEBUG => $ENV{PTDEBUG} || 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
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# 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 PTDEBUG => $ENV{PTDEBUG} || 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;
|
|
PTDEBUG && _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}};
|
|
|
|
PTDEBUG && _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);
|
|
}
|
|
}
|
|
PTDEBUG && _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;
|
|
PTDEBUG && _d($sql);
|
|
my $expl = $dbh->selectrow_hashref($sql);
|
|
$expl = { map { lc($_) => $expl->{$_} } keys %$expl };
|
|
if ( $expl->{possible_keys} ) {
|
|
PTDEBUG && _d('possible_keys =', $expl->{possible_keys});
|
|
my @candidates = split(',', $expl->{possible_keys});
|
|
my %possible = map { $_ => 1 } @candidates;
|
|
if ( $expl->{key} ) {
|
|
PTDEBUG && _d('MySQL chose', $expl->{key});
|
|
unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
|
|
PTDEBUG && _d('Before deduping:', join(', ', @candidates));
|
|
my %seen;
|
|
@candidates = grep { !$seen{$_}++ } @candidates;
|
|
}
|
|
PTDEBUG && _d('Final list:', join(', ', @candidates));
|
|
return @candidates;
|
|
}
|
|
else {
|
|
PTDEBUG && _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);
|
|
PTDEBUG && _d('Checking', $db_tbl);
|
|
|
|
my $sql = "SHOW TABLES FROM " . $q->quote($db)
|
|
. ' LIKE ' . $q->literal_like($tbl);
|
|
PTDEBUG && _d($sql);
|
|
my $row;
|
|
eval {
|
|
$row = $dbh->selectrow_arrayref($sql);
|
|
};
|
|
if ( $EVAL_ERROR ) {
|
|
PTDEBUG && _d($EVAL_ERROR);
|
|
return 0;
|
|
}
|
|
if ( !$row->[0] || $row->[0] ne $tbl ) {
|
|
PTDEBUG && _d('Table does not exist');
|
|
return 0;
|
|
}
|
|
|
|
PTDEBUG && _d('Table exists; no privs to check');
|
|
return 1 unless $args{all_privs};
|
|
|
|
$sql = "SHOW FULL COLUMNS FROM $db_tbl";
|
|
PTDEBUG && _d($sql);
|
|
eval {
|
|
$row = $dbh->selectrow_hashref($sql);
|
|
};
|
|
if ( $EVAL_ERROR ) {
|
|
PTDEBUG && _d($EVAL_ERROR);
|
|
return 0;
|
|
}
|
|
if ( !scalar keys %$row ) {
|
|
PTDEBUG && _d('Table has no columns:', Dumper($row));
|
|
return 0;
|
|
}
|
|
my $privs = $row->{privileges} || $row->{Privileges};
|
|
|
|
$sql = "DELETE FROM $db_tbl LIMIT 0";
|
|
PTDEBUG && _d($sql);
|
|
eval {
|
|
$dbh->do($sql);
|
|
};
|
|
my $can_delete = $EVAL_ERROR ? 0 : 1;
|
|
|
|
PTDEBUG && _d('User privs on', $db_tbl, ':', $privs,
|
|
($can_delete ? 'delete' : ''));
|
|
|
|
if ( !($privs =~ m/select/ && $privs =~ m/insert/ && $privs =~ m/update/
|
|
&& $can_delete) ) {
|
|
PTDEBUG && _d('User does not have all privs');
|
|
return 0;
|
|
}
|
|
|
|
PTDEBUG && _d('User has all privs');
|
|
return 1;
|
|
}
|
|
|
|
sub get_engine {
|
|
my ( $self, $ddl, $opts ) = @_;
|
|
my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
|
|
PTDEBUG && _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;
|
|
PTDEBUG && _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;
|
|
|
|
PTDEBUG && _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};
|
|
}
|
|
PTDEBUG && $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}};
|
|
PTDEBUG && _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 {
|
|
PTDEBUG && _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 PTDEBUG => $ENV{PTDEBUG} || 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 ) {
|
|
PTDEBUG && _d('No new DB to use');
|
|
return;
|
|
}
|
|
my $sql = 'USE ' . $quoter->quote($new);
|
|
PTDEBUG && _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 */';
|
|
PTDEBUG && _d($sql);
|
|
eval { $dbh->do($sql); };
|
|
PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
|
|
$self->_use_db($dbh, $quoter, $db);
|
|
$sql = "SHOW CREATE TABLE " . $quoter->quote($db, $tbl);
|
|
PTDEBUG && _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 */';
|
|
PTDEBUG && _d($sql);
|
|
$dbh->do($sql);
|
|
my ($key) = grep { m/create table/i } keys %$href;
|
|
if ( $key ) {
|
|
PTDEBUG && _d('This table is a base table');
|
|
$self->{tables}->{$db}->{$tbl} = [ 'table', $href->{$key} ];
|
|
}
|
|
else {
|
|
PTDEBUG && _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 ) = @_;
|
|
PTDEBUG && _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);
|
|
PTDEBUG && _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)";
|
|
PTDEBUG && _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 */';
|
|
PTDEBUG && _d($sql);
|
|
eval { $dbh->do($sql); };
|
|
PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
|
|
$sql = "SHOW TRIGGERS FROM " . $quoter->quote($db);
|
|
PTDEBUG && _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 */';
|
|
PTDEBUG && _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);
|
|
PTDEBUG && _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;
|
|
}
|
|
PTDEBUG && _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;
|
|
}
|
|
PTDEBUG && _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
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# DSNParser package
|
|
# This package is a copy without comments from the original. The original
|
|
# with comments and its test file can be found in the Bazaar repository at,
|
|
# lib/DSNParser.pm
|
|
# t/lib/DSNParser.t
|
|
# See https://launchpad.net/percona-toolkit for more information.
|
|
# ###########################################################################
|
|
{
|
|
package DSNParser;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
use Data::Dumper;
|
|
$Data::Dumper::Indent = 0;
|
|
$Data::Dumper::Quotekeys = 0;
|
|
|
|
eval {
|
|
require DBI;
|
|
};
|
|
my $have_dbi = $EVAL_ERROR ? 0 : 1;
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
foreach my $arg ( qw(opts) ) {
|
|
die "I need a $arg argument" unless $args{$arg};
|
|
}
|
|
my $self = {
|
|
opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
|
|
};
|
|
foreach my $opt ( @{$args{opts}} ) {
|
|
if ( !$opt->{key} || !$opt->{desc} ) {
|
|
die "Invalid DSN option: ", Dumper($opt);
|
|
}
|
|
PTDEBUG && _d('DSN option:',
|
|
join(', ',
|
|
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
|
|
keys %$opt
|
|
)
|
|
);
|
|
$self->{opts}->{$opt->{key}} = {
|
|
dsn => $opt->{dsn},
|
|
desc => $opt->{desc},
|
|
copy => $opt->{copy} || 0,
|
|
};
|
|
}
|
|
return bless $self, $class;
|
|
}
|
|
|
|
sub prop {
|
|
my ( $self, $prop, $value ) = @_;
|
|
if ( @_ > 2 ) {
|
|
PTDEBUG && _d('Setting', $prop, 'property');
|
|
$self->{$prop} = $value;
|
|
}
|
|
return $self->{$prop};
|
|
}
|
|
|
|
sub parse {
|
|
my ( $self, $dsn, $prev, $defaults ) = @_;
|
|
if ( !$dsn ) {
|
|
PTDEBUG && _d('No DSN to parse');
|
|
return;
|
|
}
|
|
PTDEBUG && _d('Parsing', $dsn);
|
|
$prev ||= {};
|
|
$defaults ||= {};
|
|
my %given_props;
|
|
my %final_props;
|
|
my $opts = $self->{opts};
|
|
|
|
foreach my $dsn_part ( split(/,/, $dsn) ) {
|
|
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
|
|
$given_props{$prop_key} = $prop_val;
|
|
}
|
|
else {
|
|
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
|
|
$given_props{h} = $dsn_part;
|
|
}
|
|
}
|
|
|
|
foreach my $key ( keys %$opts ) {
|
|
PTDEBUG && _d('Finding value for', $key);
|
|
$final_props{$key} = $given_props{$key};
|
|
if ( !defined $final_props{$key}
|
|
&& defined $prev->{$key} && $opts->{$key}->{copy} )
|
|
{
|
|
$final_props{$key} = $prev->{$key};
|
|
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
|
|
}
|
|
if ( !defined $final_props{$key} ) {
|
|
$final_props{$key} = $defaults->{$key};
|
|
PTDEBUG && _d('Copying value for', $key, 'from defaults');
|
|
}
|
|
}
|
|
|
|
foreach my $key ( keys %given_props ) {
|
|
die "Unknown DSN option '$key' in '$dsn'. For more details, "
|
|
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
|
|
. "for complete documentation."
|
|
unless exists $opts->{$key};
|
|
}
|
|
if ( (my $required = $self->prop('required')) ) {
|
|
foreach my $key ( keys %$required ) {
|
|
die "Missing required DSN option '$key' in '$dsn'. For more details, "
|
|
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
|
|
. "for complete documentation."
|
|
unless $final_props{$key};
|
|
}
|
|
}
|
|
|
|
return \%final_props;
|
|
}
|
|
|
|
sub parse_options {
|
|
my ( $self, $o ) = @_;
|
|
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
|
|
my $dsn_string
|
|
= join(',',
|
|
map { "$_=".$o->get($_); }
|
|
grep { $o->has($_) && $o->get($_) }
|
|
keys %{$self->{opts}}
|
|
);
|
|
PTDEBUG && _d('DSN string made from options:', $dsn_string);
|
|
return $self->parse($dsn_string);
|
|
}
|
|
|
|
sub as_string {
|
|
my ( $self, $dsn, $props ) = @_;
|
|
return $dsn unless ref $dsn;
|
|
my %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';
|
|
}
|
|
PTDEBUG && _d($dsn);
|
|
return ($dsn, $info->{u}, $info->{p});
|
|
}
|
|
|
|
sub fill_in_dsn {
|
|
my ( $self, $dbh, $dsn ) = @_;
|
|
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
|
|
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
|
|
$user =~ s/@.*//;
|
|
$dsn->{h} ||= $vars->{hostname}->{Value};
|
|
$dsn->{S} ||= $vars->{'socket'}->{Value};
|
|
$dsn->{P} ||= $vars->{port}->{Value};
|
|
$dsn->{u} ||= $user;
|
|
$dsn->{D} ||= $db;
|
|
}
|
|
|
|
sub get_dbh {
|
|
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
|
|
$opts ||= {};
|
|
my $defaults = {
|
|
AutoCommit => 0,
|
|
RaiseError => 1,
|
|
PrintError => 0,
|
|
ShowErrorStatement => 1,
|
|
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
|
|
};
|
|
@{$defaults}{ keys %$opts } = values %$opts;
|
|
|
|
if ( $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-- ) {
|
|
PTDEBUG && _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';
|
|
PTDEBUG && _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" : '')
|
|
. '\'*/';
|
|
PTDEBUG && _d($dbh, $sql);
|
|
$dbh->do($sql);
|
|
|
|
if ( my ($charset) = $cxn_string =~ m/charset=(\w+)/ ) {
|
|
$sql = "/*!40101 SET NAMES $charset*/";
|
|
PTDEBUG && _d($dbh, ':', $sql);
|
|
$dbh->do($sql);
|
|
PTDEBUG && _d('Enabling charset for STDOUT');
|
|
if ( $charset eq 'utf8' ) {
|
|
binmode(STDOUT, ':utf8')
|
|
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
|
|
}
|
|
else {
|
|
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
|
|
}
|
|
}
|
|
|
|
if ( $self->prop('set-vars') ) {
|
|
$sql = "SET " . $self->prop('set-vars');
|
|
PTDEBUG && _d($dbh, ':', $sql);
|
|
$dbh->do($sql);
|
|
}
|
|
}
|
|
};
|
|
if ( !$dbh && $EVAL_ERROR ) {
|
|
PTDEBUG && _d($EVAL_ERROR);
|
|
if ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
|
|
PTDEBUG && _d('Going to try again without utf8 support');
|
|
delete $defaults->{mysql_enable_utf8};
|
|
}
|
|
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;
|
|
}
|
|
}
|
|
}
|
|
|
|
PTDEBUG && _d('DBH info: ',
|
|
$dbh,
|
|
Dumper($dbh->selectrow_hashref(
|
|
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
|
|
'Connection info:', $dbh->{mysql_hostinfo},
|
|
'Character set info:', Dumper($dbh->selectall_arrayref(
|
|
'SHOW VARIABLES LIKE "character_set%"', { Slice => {}})),
|
|
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
|
|
'$DBI::VERSION:', $DBI::VERSION,
|
|
);
|
|
|
|
return $dbh;
|
|
}
|
|
|
|
sub get_hostname {
|
|
my ( $self, $dbh ) = @_;
|
|
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
|
|
return $host;
|
|
}
|
|
my ( $hostname, $one ) = $dbh->selectrow_array(
|
|
'SELECT /*!50038 @@hostname, */ 1');
|
|
return $hostname;
|
|
}
|
|
|
|
sub disconnect {
|
|
my ( $self, $dbh ) = @_;
|
|
PTDEBUG && $self->print_active_handles($dbh);
|
|
$dbh->disconnect;
|
|
}
|
|
|
|
sub print_active_handles {
|
|
my ( $self, $thing, $level ) = @_;
|
|
$level ||= 0;
|
|
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
|
|
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
|
|
or die "Cannot print: $OS_ERROR";
|
|
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
|
|
$self->print_active_handles( $handle, $level + 1 );
|
|
}
|
|
}
|
|
|
|
sub copy {
|
|
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
|
|
die 'I need a dsn_1 argument' unless $dsn_1;
|
|
die 'I need a dsn_2 argument' unless $dsn_2;
|
|
my %new_dsn = map {
|
|
my $key = $_;
|
|
my $val;
|
|
if ( $args{overwrite} ) {
|
|
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
|
|
}
|
|
else {
|
|
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
|
|
}
|
|
$key => $val;
|
|
} keys %{$self->{opts}};
|
|
return \%new_dsn;
|
|
}
|
|
|
|
sub _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
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# OptionParser package
|
|
# This package is a copy without comments from the original. The original
|
|
# with comments and its test file can be found in the Bazaar repository at,
|
|
# lib/OptionParser.pm
|
|
# t/lib/OptionParser.t
|
|
# See https://launchpad.net/percona-toolkit for more information.
|
|
# ###########################################################################
|
|
{
|
|
package OptionParser;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
use List::Util qw(max);
|
|
use Getopt::Long;
|
|
|
|
my $POD_link_re = '[LC]<"?([^">]+)"?>';
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
my @required_args = qw();
|
|
foreach my $arg ( @required_args ) {
|
|
die "I need a $arg argument" unless $args{$arg};
|
|
}
|
|
|
|
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
|
|
$program_name ||= $PROGRAM_NAME;
|
|
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
|
|
|
|
my %attributes = (
|
|
'type' => 1,
|
|
'short form' => 1,
|
|
'group' => 1,
|
|
'default' => 1,
|
|
'cumulative' => 1,
|
|
'negatable' => 1,
|
|
);
|
|
|
|
my $self = {
|
|
head1 => 'OPTIONS', # These args are used internally
|
|
skip_rules => 0, # to instantiate another Option-
|
|
item => '--(.*)', # Parser obj that parses the
|
|
attributes => \%attributes, # DSN OPTIONS section. Tools
|
|
parse_attributes => \&_parse_attribs, # don't tinker with these args.
|
|
|
|
%args,
|
|
|
|
strict => 1, # disabled by a special rule
|
|
program_name => $program_name,
|
|
opts => {},
|
|
got_opts => 0,
|
|
short_opts => {},
|
|
defaults => {},
|
|
groups => {},
|
|
allowed_groups => {},
|
|
errors => [],
|
|
rules => [], # desc of rules for --help
|
|
mutex => [], # rule: opts are mutually exclusive
|
|
atleast1 => [], # rule: at least one opt is required
|
|
disables => {}, # rule: opt disables other opts
|
|
defaults_to => {}, # rule: opt defaults to value of other opt
|
|
DSNParser => undef,
|
|
default_files => [
|
|
"/etc/percona-toolkit/percona-toolkit.conf",
|
|
"/etc/percona-toolkit/$program_name.conf",
|
|
"$home/.percona-toolkit.conf",
|
|
"$home/.$program_name.conf",
|
|
],
|
|
types => {
|
|
string => 's', # standard Getopt type
|
|
int => 'i', # standard Getopt type
|
|
float => 'f', # standard Getopt type
|
|
Hash => 'H', # hash, formed from a comma-separated list
|
|
hash => 'h', # hash as above, but only if a value is given
|
|
Array => 'A', # array, similar to Hash
|
|
array => 'a', # array, similar to hash
|
|
DSN => 'd', # DSN
|
|
size => 'z', # size with kMG suffix (powers of 2^10)
|
|
time => 'm', # time, with an optional suffix of s/h/m/d
|
|
},
|
|
};
|
|
|
|
return bless $self, $class;
|
|
}
|
|
|
|
sub get_specs {
|
|
my ( $self, $file ) = @_;
|
|
$file ||= $self->{file} || __FILE__;
|
|
my @specs = $self->_pod_to_specs($file);
|
|
$self->_parse_specs(@specs);
|
|
|
|
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
|
|
my $contents = do { local $/ = undef; <$fh> };
|
|
close $fh;
|
|
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
|
|
PTDEBUG && _d('Parsing DSN OPTIONS');
|
|
my $dsn_attribs = {
|
|
dsn => 1,
|
|
copy => 1,
|
|
};
|
|
my $parse_dsn_attribs = sub {
|
|
my ( $self, $option, $attribs ) = @_;
|
|
map {
|
|
my $val = $attribs->{$_};
|
|
if ( $val ) {
|
|
$val = $val eq 'yes' ? 1
|
|
: $val eq 'no' ? 0
|
|
: $val;
|
|
$attribs->{$_} = $val;
|
|
}
|
|
} keys %$attribs;
|
|
return {
|
|
key => $option,
|
|
%$attribs,
|
|
};
|
|
};
|
|
my $dsn_o = new OptionParser(
|
|
description => 'DSN OPTIONS',
|
|
head1 => 'DSN OPTIONS',
|
|
dsn => 0, # XXX don't infinitely recurse!
|
|
item => '\* (.)', # key opts are a single character
|
|
skip_rules => 1, # no rules before opts
|
|
attributes => $dsn_attribs,
|
|
parse_attributes => $parse_dsn_attribs,
|
|
);
|
|
my @dsn_opts = map {
|
|
my $opts = {
|
|
key => $_->{spec}->{key},
|
|
dsn => $_->{spec}->{dsn},
|
|
copy => $_->{spec}->{copy},
|
|
desc => $_->{desc},
|
|
};
|
|
$opts;
|
|
} $dsn_o->_pod_to_specs($file);
|
|
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
|
|
}
|
|
|
|
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
|
|
$self->{version} = $1;
|
|
PTDEBUG && _d($self->{version});
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub DSNParser {
|
|
my ( $self ) = @_;
|
|
return $self->{DSNParser};
|
|
};
|
|
|
|
sub get_defaults_files {
|
|
my ( $self ) = @_;
|
|
return @{$self->{default_files}};
|
|
}
|
|
|
|
sub _pod_to_specs {
|
|
my ( $self, $file ) = @_;
|
|
$file ||= $self->{file} || __FILE__;
|
|
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
|
|
|
|
my @specs = ();
|
|
my @rules = ();
|
|
my $para;
|
|
|
|
local $INPUT_RECORD_SEPARATOR = '';
|
|
while ( $para = <$fh> ) {
|
|
next unless $para =~ m/^=head1 $self->{head1}/;
|
|
last;
|
|
}
|
|
|
|
while ( $para = <$fh> ) {
|
|
last if $para =~ m/^=over/;
|
|
next if $self->{skip_rules};
|
|
chomp $para;
|
|
$para =~ s/\s+/ /g;
|
|
$para =~ s/$POD_link_re/$1/go;
|
|
PTDEBUG && _d('Option rule:', $para);
|
|
push @rules, $para;
|
|
}
|
|
|
|
die "POD has no $self->{head1} section" unless $para;
|
|
|
|
do {
|
|
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
|
|
chomp $para;
|
|
PTDEBUG && _d($para);
|
|
my %attribs;
|
|
|
|
$para = <$fh>; # read next paragraph, possibly attributes
|
|
|
|
if ( $para =~ m/: / ) { # attributes
|
|
$para =~ s/\s+\Z//g;
|
|
%attribs = map {
|
|
my ( $attrib, $val) = split(/: /, $_);
|
|
die "Unrecognized attribute for --$option: $attrib"
|
|
unless $self->{attributes}->{$attrib};
|
|
($attrib, $val);
|
|
} split(/; /, $para);
|
|
if ( $attribs{'short form'} ) {
|
|
$attribs{'short form'} =~ s/-//;
|
|
}
|
|
$para = <$fh>; # read next paragraph, probably short help desc
|
|
}
|
|
else {
|
|
PTDEBUG && _d('Option has no attributes');
|
|
}
|
|
|
|
$para =~ s/\s+\Z//g;
|
|
$para =~ s/\s+/ /g;
|
|
$para =~ s/$POD_link_re/$1/go;
|
|
|
|
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
|
|
PTDEBUG && _d('Short help:', $para);
|
|
|
|
die "No description after option spec $option" if $para =~ m/^=item/;
|
|
|
|
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
|
|
$option = $base_option;
|
|
$attribs{'negatable'} = 1;
|
|
}
|
|
|
|
push @specs, {
|
|
spec => $self->{parse_attributes}->($self, $option, \%attribs),
|
|
desc => $para
|
|
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
|
|
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
|
|
};
|
|
}
|
|
while ( $para = <$fh> ) {
|
|
last unless $para;
|
|
if ( $para =~ m/^=head1/ ) {
|
|
$para = undef; # Can't 'last' out of a do {} block.
|
|
last;
|
|
}
|
|
last if $para =~ m/^=item /;
|
|
}
|
|
} while ( $para );
|
|
|
|
die "No valid specs in $self->{head1}" unless @specs;
|
|
|
|
close $fh;
|
|
return @specs, @rules;
|
|
}
|
|
|
|
sub _parse_specs {
|
|
my ( $self, @specs ) = @_;
|
|
my %disables; # special rule that requires deferred checking
|
|
|
|
foreach my $opt ( @specs ) {
|
|
if ( ref $opt ) { # It's an option spec, not a rule.
|
|
PTDEBUG && _d('Parsing opt spec:',
|
|
map { ($_, '=>', $opt->{$_}) } keys %$opt);
|
|
|
|
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
|
|
if ( !$long ) {
|
|
die "Cannot parse long option from spec $opt->{spec}";
|
|
}
|
|
$opt->{long} = $long;
|
|
|
|
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
|
|
$self->{opts}->{$long} = $opt;
|
|
|
|
if ( length $long == 1 ) {
|
|
PTDEBUG && _d('Long opt', $long, 'looks like short opt');
|
|
$self->{short_opts}->{$long} = $long;
|
|
}
|
|
|
|
if ( $short ) {
|
|
die "Duplicate short option -$short"
|
|
if exists $self->{short_opts}->{$short};
|
|
$self->{short_opts}->{$short} = $long;
|
|
$opt->{short} = $short;
|
|
}
|
|
else {
|
|
$opt->{short} = undef;
|
|
}
|
|
|
|
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
|
|
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
|
|
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
|
|
|
|
$opt->{group} ||= 'default';
|
|
$self->{groups}->{ $opt->{group} }->{$long} = 1;
|
|
|
|
$opt->{value} = undef;
|
|
$opt->{got} = 0;
|
|
|
|
my ( $type ) = $opt->{spec} =~ m/=(.)/;
|
|
$opt->{type} = $type;
|
|
PTDEBUG && _d($long, 'type:', $type);
|
|
|
|
|
|
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
|
|
|
|
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
|
|
$self->{defaults}->{$long} = defined $def ? $def : 1;
|
|
PTDEBUG && _d($long, 'default:', $def);
|
|
}
|
|
|
|
if ( $long eq 'config' ) {
|
|
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
|
|
}
|
|
|
|
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
|
|
$disables{$long} = $dis;
|
|
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
|
|
}
|
|
|
|
$self->{opts}->{$long} = $opt;
|
|
}
|
|
else { # It's an option rule, not a spec.
|
|
PTDEBUG && _d('Parsing rule:', $opt);
|
|
push @{$self->{rules}}, $opt;
|
|
my @participants = $self->_get_participants($opt);
|
|
my $rule_ok = 0;
|
|
|
|
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
|
|
$rule_ok = 1;
|
|
push @{$self->{mutex}}, \@participants;
|
|
PTDEBUG && _d(@participants, 'are mutually exclusive');
|
|
}
|
|
if ( $opt =~ m/at least one|one and only one/ ) {
|
|
$rule_ok = 1;
|
|
push @{$self->{atleast1}}, \@participants;
|
|
PTDEBUG && _d(@participants, 'require at least one');
|
|
}
|
|
if ( $opt =~ m/default to/ ) {
|
|
$rule_ok = 1;
|
|
$self->{defaults_to}->{$participants[0]} = $participants[1];
|
|
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
|
|
}
|
|
if ( $opt =~ m/restricted to option groups/ ) {
|
|
$rule_ok = 1;
|
|
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
|
|
my @groups = split(',', $groups);
|
|
%{$self->{allowed_groups}->{$participants[0]}} = map {
|
|
s/\s+//;
|
|
$_ => 1;
|
|
} @groups;
|
|
}
|
|
if( $opt =~ m/accepts additional command-line arguments/ ) {
|
|
$rule_ok = 1;
|
|
$self->{strict} = 0;
|
|
PTDEBUG && _d("Strict mode disabled by rule");
|
|
}
|
|
|
|
die "Unrecognized option rule: $opt" unless $rule_ok;
|
|
}
|
|
}
|
|
|
|
foreach my $long ( keys %disables ) {
|
|
my @participants = $self->_get_participants($disables{$long});
|
|
$self->{disables}->{$long} = \@participants;
|
|
PTDEBUG && _d('Option', $long, 'disables', @participants);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub _get_participants {
|
|
my ( $self, $str ) = @_;
|
|
my @participants;
|
|
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
|
|
die "Option --$long does not exist while processing rule $str"
|
|
unless exists $self->{opts}->{$long};
|
|
push @participants, $long;
|
|
}
|
|
PTDEBUG && _d('Participants for', $str, ':', @participants);
|
|
return @participants;
|
|
}
|
|
|
|
sub opts {
|
|
my ( $self ) = @_;
|
|
my %opts = %{$self->{opts}};
|
|
return %opts;
|
|
}
|
|
|
|
sub short_opts {
|
|
my ( $self ) = @_;
|
|
my %short_opts = %{$self->{short_opts}};
|
|
return %short_opts;
|
|
}
|
|
|
|
sub set_defaults {
|
|
my ( $self, %defaults ) = @_;
|
|
$self->{defaults} = {};
|
|
foreach my $long ( keys %defaults ) {
|
|
die "Cannot set default for nonexistent option $long"
|
|
unless exists $self->{opts}->{$long};
|
|
$self->{defaults}->{$long} = $defaults{$long};
|
|
PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub get_defaults {
|
|
my ( $self ) = @_;
|
|
return $self->{defaults};
|
|
}
|
|
|
|
sub get_groups {
|
|
my ( $self ) = @_;
|
|
return $self->{groups};
|
|
}
|
|
|
|
sub _set_option {
|
|
my ( $self, $opt, $val ) = @_;
|
|
my $long = exists $self->{opts}->{$opt} ? $opt
|
|
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
|
|
: die "Getopt::Long gave a nonexistent option: $opt";
|
|
|
|
$opt = $self->{opts}->{$long};
|
|
if ( $opt->{is_cumulative} ) {
|
|
$opt->{value}++;
|
|
}
|
|
else {
|
|
$opt->{value} = $val;
|
|
}
|
|
$opt->{got} = 1;
|
|
PTDEBUG && _d('Got option', $long, '=', $val);
|
|
}
|
|
|
|
sub get_opts {
|
|
my ( $self ) = @_;
|
|
|
|
foreach my $long ( keys %{$self->{opts}} ) {
|
|
$self->{opts}->{$long}->{got} = 0;
|
|
$self->{opts}->{$long}->{value}
|
|
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
|
|
: $self->{opts}->{$long}->{is_cumulative} ? 0
|
|
: undef;
|
|
}
|
|
$self->{got_opts} = 0;
|
|
|
|
$self->{errors} = [];
|
|
|
|
if ( @ARGV && $ARGV[0] eq "--config" ) {
|
|
shift @ARGV;
|
|
$self->_set_option('config', shift @ARGV);
|
|
}
|
|
if ( $self->has('config') ) {
|
|
my @extra_args;
|
|
foreach my $filename ( split(',', $self->get('config')) ) {
|
|
eval {
|
|
push @extra_args, $self->_read_config_file($filename);
|
|
};
|
|
if ( $EVAL_ERROR ) {
|
|
if ( $self->got('config') ) {
|
|
die $EVAL_ERROR;
|
|
}
|
|
elsif ( PTDEBUG ) {
|
|
_d($EVAL_ERROR);
|
|
}
|
|
}
|
|
}
|
|
unshift @ARGV, @extra_args;
|
|
}
|
|
|
|
Getopt::Long::Configure('no_ignore_case', 'bundling');
|
|
GetOptions(
|
|
map { $_->{spec} => sub { $self->_set_option(@_); } }
|
|
grep { $_->{long} ne 'config' } # --config is handled specially above.
|
|
values %{$self->{opts}}
|
|
) or $self->save_error('Error parsing options');
|
|
|
|
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
|
|
if ( $self->{version} ) {
|
|
print $self->{version}, "\n";
|
|
}
|
|
else {
|
|
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
|
|
}
|
|
exit 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;
|
|
PTDEBUG && _d('Unset options', @disable_opts,
|
|
'because', $long,'disables them');
|
|
}
|
|
|
|
if ( exists $self->{allowed_groups}->{$long} ) {
|
|
|
|
my @restricted_groups = grep {
|
|
!exists $self->{allowed_groups}->{$long}->{$_}
|
|
} keys %{$self->{groups}};
|
|
|
|
my @restricted_opts;
|
|
foreach my $restricted_group ( @restricted_groups ) {
|
|
RESTRICTED_OPT:
|
|
foreach my $restricted_opt (
|
|
keys %{$self->{groups}->{$restricted_group}} )
|
|
{
|
|
next RESTRICTED_OPT if $restricted_opt eq $long;
|
|
push @restricted_opts, $restricted_opt
|
|
if $self->{opts}->{$restricted_opt}->{got};
|
|
}
|
|
}
|
|
|
|
if ( @restricted_opts ) {
|
|
my $err;
|
|
if ( @restricted_opts == 1 ) {
|
|
$err = "--$restricted_opts[0]";
|
|
}
|
|
else {
|
|
$err = join(', ',
|
|
map { "--$self->{opts}->{$_}->{long}" }
|
|
grep { $_ }
|
|
@restricted_opts[0..scalar(@restricted_opts) - 2]
|
|
)
|
|
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
|
|
}
|
|
$self->save_error("--$long is not allowed with $err");
|
|
}
|
|
}
|
|
|
|
}
|
|
elsif ( $opt->{is_required} ) {
|
|
$self->save_error("Required option --$long must be specified");
|
|
}
|
|
|
|
$self->_validate_type($opt);
|
|
if ( $opt->{parsed} ) {
|
|
delete $long[$i];
|
|
}
|
|
else {
|
|
PTDEBUG && _d('Temporarily failed to parse', $long);
|
|
}
|
|
}
|
|
|
|
die "Failed to parse options, possibly due to circular dependencies"
|
|
if @long == $long_last;
|
|
$long_last = @long;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub _validate_type {
|
|
my ( $self, $opt ) = @_;
|
|
return unless $opt;
|
|
|
|
if ( !$opt->{type} ) {
|
|
$opt->{parsed} = 1;
|
|
return;
|
|
}
|
|
|
|
my $val = $opt->{value};
|
|
|
|
if ( $val && $opt->{type} eq 'm' ) { # type time
|
|
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
|
|
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
|
|
if ( !$suffix ) {
|
|
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
|
|
$suffix = $s || 's';
|
|
PTDEBUG && _d('No suffix given; using', $suffix, 'for',
|
|
$opt->{long}, '(value:', $val, ')');
|
|
}
|
|
if ( $suffix =~ m/[smhd]/ ) {
|
|
$val = $suffix eq 's' ? $num # Seconds
|
|
: $suffix eq 'm' ? $num * 60 # Minutes
|
|
: $suffix eq 'h' ? $num * 3600 # Hours
|
|
: $num * 86400; # Days
|
|
$opt->{value} = ($prefix || '') . $val;
|
|
PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
|
|
}
|
|
else {
|
|
$self->save_error("Invalid time suffix for --$opt->{long}");
|
|
}
|
|
}
|
|
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
|
|
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
|
|
my $prev = {};
|
|
my $from_key = $self->{defaults_to}->{ $opt->{long} };
|
|
if ( $from_key ) {
|
|
PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
|
|
if ( $self->{opts}->{$from_key}->{parsed} ) {
|
|
$prev = $self->{opts}->{$from_key}->{value};
|
|
}
|
|
else {
|
|
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
|
|
$from_key, 'parsed');
|
|
return;
|
|
}
|
|
}
|
|
my $defaults = $self->{DSNParser}->parse_options($self);
|
|
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
|
|
}
|
|
elsif ( $val && $opt->{type} eq 'z' ) { # type size
|
|
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
|
|
$self->_parse_size($opt, $val);
|
|
}
|
|
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
|
|
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
|
|
}
|
|
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
|
|
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
|
|
}
|
|
else {
|
|
PTDEBUG && _d('Nothing to validate for option',
|
|
$opt->{long}, 'type', $opt->{type}, 'value', $val);
|
|
}
|
|
|
|
$opt->{parsed} = 1;
|
|
return;
|
|
}
|
|
|
|
sub get {
|
|
my ( $self, $opt ) = @_;
|
|
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
|
|
die "Option $opt does not exist"
|
|
unless $long && exists $self->{opts}->{$long};
|
|
return $self->{opts}->{$long}->{value};
|
|
}
|
|
|
|
sub got {
|
|
my ( $self, $opt ) = @_;
|
|
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
|
|
die "Option $opt does not exist"
|
|
unless $long && exists $self->{opts}->{$long};
|
|
return $self->{opts}->{$long}->{got};
|
|
}
|
|
|
|
sub has {
|
|
my ( $self, $opt ) = @_;
|
|
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
|
|
return defined $long ? exists $self->{opts}->{$long} : 0;
|
|
}
|
|
|
|
sub set {
|
|
my ( $self, $opt, $val ) = @_;
|
|
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
|
|
die "Option $opt does not exist"
|
|
unless $long && exists $self->{opts}->{$long};
|
|
$self->{opts}->{$long}->{value} = $val;
|
|
return;
|
|
}
|
|
|
|
sub save_error {
|
|
my ( $self, $error ) = @_;
|
|
push @{$self->{errors}}, $error;
|
|
return;
|
|
}
|
|
|
|
sub errors {
|
|
my ( $self ) = @_;
|
|
return $self->{errors};
|
|
}
|
|
|
|
sub usage {
|
|
my ( $self ) = @_;
|
|
warn "No usage string is set" unless $self->{usage}; # XXX
|
|
return "Usage: " . ($self->{usage} || '') . "\n";
|
|
}
|
|
|
|
sub descr {
|
|
my ( $self ) = @_;
|
|
warn "No description string is set" unless $self->{description}; # XXX
|
|
my $descr = ($self->{description} || $self->{program_name} || '')
|
|
. " For more details, please use the --help option, "
|
|
. "or try 'perldoc $PROGRAM_NAME' "
|
|
. "for complete documentation.";
|
|
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
|
|
unless $ENV{DONT_BREAK_LINES};
|
|
$descr =~ s/ +$//mg;
|
|
return $descr;
|
|
}
|
|
|
|
sub usage_or_errors {
|
|
my ( $self, $file, $return ) = @_;
|
|
$file ||= $self->{file} || __FILE__;
|
|
|
|
if ( !$self->{description} || !$self->{usage} ) {
|
|
PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
|
|
my %synop = $self->_parse_synopsis($file);
|
|
$self->{description} ||= $synop{description};
|
|
$self->{usage} ||= $synop{usage};
|
|
PTDEBUG && _d("Description:", $self->{description},
|
|
"\nUsage:", $self->{usage});
|
|
}
|
|
|
|
if ( $self->{opts}->{help}->{got} ) {
|
|
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
|
|
exit 0 unless $return;
|
|
}
|
|
elsif ( scalar @{$self->{errors}} ) {
|
|
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
|
|
exit 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' ) {
|
|
PTDEBUG && _d('NULL size for', $opt->{long});
|
|
$opt->{value} = 'null';
|
|
return;
|
|
}
|
|
|
|
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
|
|
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
|
|
if ( defined $num ) {
|
|
if ( $factor ) {
|
|
$num *= $factor_for{$factor};
|
|
PTDEBUG && _d('Setting option', $opt->{y},
|
|
'to num', $num, '* factor', $factor);
|
|
}
|
|
$opt->{value} = ($pre || '') . $num;
|
|
}
|
|
else {
|
|
$self->save_error("Invalid size for --$opt->{long}");
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub _parse_attribs {
|
|
my ( $self, $option, $attribs ) = @_;
|
|
my $types = $self->{types};
|
|
return $option
|
|
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
|
|
. ($attribs->{'negatable'} ? '!' : '' )
|
|
. ($attribs->{'cumulative'} ? '+' : '' )
|
|
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
|
|
}
|
|
|
|
sub _parse_synopsis {
|
|
my ( $self, $file ) = @_;
|
|
$file ||= $self->{file} || __FILE__;
|
|
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
|
|
|
|
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
|
|
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
|
|
my $para;
|
|
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
|
|
die "$file does not contain a SYNOPSIS section" unless $para;
|
|
my @synop;
|
|
for ( 1..2 ) { # 1 for the usage, 2 for the description
|
|
my $para = <$fh>;
|
|
push @synop, $para;
|
|
}
|
|
close $fh;
|
|
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
|
|
my ($usage, $desc) = @synop;
|
|
die "The SYNOPSIS section in $file is not formatted properly"
|
|
unless $usage && $desc;
|
|
|
|
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
|
|
chomp $usage;
|
|
|
|
$desc =~ s/\n/ /g;
|
|
$desc =~ s/\s{2,}/ /g;
|
|
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
|
|
$desc =~ s/\s+$//;
|
|
|
|
return (
|
|
description => $desc,
|
|
usage => $usage,
|
|
);
|
|
};
|
|
|
|
sub _d {
|
|
my ($package, undef, $line) = caller 0;
|
|
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
|
|
map { defined $_ ? $_ : 'undef' }
|
|
@_;
|
|
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
|
|
}
|
|
|
|
if ( PTDEBUG ) {
|
|
print '# ', $^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
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# KeySize 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/KeySize.pm
|
|
# t/lib/KeySize.t
|
|
# See https://launchpad.net/percona-toolkit for more information.
|
|
# ###########################################################################
|
|
{
|
|
package KeySize;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
my $self = { %args };
|
|
return bless $self, $class;
|
|
}
|
|
|
|
sub get_key_size {
|
|
my ( $self, %args ) = @_;
|
|
foreach my $arg ( qw(name cols tbl_name tbl_struct dbh) ) {
|
|
die "I need a $arg argument" unless $args{$arg};
|
|
}
|
|
my $name = $args{name};
|
|
my @cols = @{$args{cols}};
|
|
my $dbh = $args{dbh};
|
|
|
|
$self->{explain} = '';
|
|
$self->{query} = '';
|
|
$self->{error} = '';
|
|
|
|
if ( @cols == 0 ) {
|
|
$self->{error} = "No columns for key $name";
|
|
return;
|
|
}
|
|
|
|
my $key_exists = $self->_key_exists(%args);
|
|
PTDEBUG && _d('Key', $name, 'exists in', $args{tbl_name}, ':',
|
|
$key_exists ? 'yes': 'no');
|
|
|
|
my $sql = 'EXPLAIN SELECT ' . join(', ', @cols)
|
|
. ' FROM ' . $args{tbl_name}
|
|
. ($key_exists ? " FORCE INDEX (`$name`)" : '')
|
|
. ' WHERE ';
|
|
my @where_cols;
|
|
foreach my $col ( @cols ) {
|
|
push @where_cols, "$col=1";
|
|
}
|
|
if ( scalar @cols == 1 ) {
|
|
push @where_cols, "$cols[0]<>1";
|
|
}
|
|
$sql .= join(' OR ', @where_cols);
|
|
$self->{query} = $sql;
|
|
PTDEBUG && _d('sql:', $sql);
|
|
|
|
my $explain;
|
|
my $sth = $dbh->prepare($sql);
|
|
eval { $sth->execute(); };
|
|
if ( $EVAL_ERROR ) {
|
|
chomp $EVAL_ERROR;
|
|
$self->{error} = "Cannot get size of $name key: $EVAL_ERROR";
|
|
return;
|
|
}
|
|
$explain = $sth->fetchrow_hashref();
|
|
|
|
$self->{explain} = $explain;
|
|
my $key_len = $explain->{key_len};
|
|
my $rows = $explain->{rows};
|
|
my $chosen_key = $explain->{key}; # May differ from $name
|
|
PTDEBUG && _d('MySQL chose key:', $chosen_key, 'len:', $key_len,
|
|
'rows:', $rows);
|
|
|
|
my $key_size = 0;
|
|
if ( $key_len && $rows ) {
|
|
if ( $chosen_key =~ m/,/ && $key_len =~ m/,/ ) {
|
|
$self->{error} = "MySQL chose multiple keys: $chosen_key";
|
|
return;
|
|
}
|
|
$key_size = $key_len * $rows;
|
|
}
|
|
else {
|
|
$self->{error} = "key_len or rows NULL in EXPLAIN:\n"
|
|
. _explain_to_text($explain);
|
|
return;
|
|
}
|
|
|
|
return $key_size, $chosen_key;
|
|
}
|
|
|
|
sub query {
|
|
my ( $self ) = @_;
|
|
return $self->{query};
|
|
}
|
|
|
|
sub explain {
|
|
my ( $self ) = @_;
|
|
return _explain_to_text($self->{explain});
|
|
}
|
|
|
|
sub error {
|
|
my ( $self ) = @_;
|
|
return $self->{error};
|
|
}
|
|
|
|
sub _key_exists {
|
|
my ( $self, %args ) = @_;
|
|
return exists $args{tbl_struct}->{keys}->{ lc $args{name} } ? 1 : 0;
|
|
}
|
|
|
|
sub _explain_to_text {
|
|
my ( $explain ) = @_;
|
|
return join("\n",
|
|
map { "$_: ".($explain->{$_} ? $explain->{$_} : 'NULL') }
|
|
sort keys %$explain
|
|
);
|
|
}
|
|
|
|
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 KeySize package
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# DuplicateKeyFinder 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/DuplicateKeyFinder.pm
|
|
# t/lib/DuplicateKeyFinder.t
|
|
# See https://launchpad.net/percona-toolkit for more information.
|
|
# ###########################################################################
|
|
{
|
|
package DuplicateKeyFinder;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
my $self = {};
|
|
return bless $self, $class;
|
|
}
|
|
|
|
sub get_duplicate_keys {
|
|
my ( $self, $keys, %args ) = @_;
|
|
die "I need a keys argument" unless $keys;
|
|
my %keys = %$keys; # Copy keys because we remove non-duplicates.
|
|
my $primary_key;
|
|
my @unique_keys;
|
|
my @normal_keys;
|
|
my @fulltext_keys;
|
|
my @dupes;
|
|
|
|
KEY:
|
|
foreach my $key ( values %keys ) {
|
|
$key->{real_cols} = [ @{$key->{cols}} ];
|
|
|
|
$key->{len_cols} = length $key->{colnames};
|
|
|
|
if ( $key->{name} eq 'PRIMARY'
|
|
|| ($args{clustered_key} && $key->{name} eq $args{clustered_key}) ) {
|
|
$primary_key = $key;
|
|
PTDEBUG && _d('primary key:', $key->{name});
|
|
next KEY;
|
|
}
|
|
|
|
my $is_fulltext = $key->{type} eq 'FULLTEXT' ? 1 : 0;
|
|
if ( $args{ignore_order} || $is_fulltext ) {
|
|
my $ordered_cols = join(',', sort(split(/,/, $key->{colnames})));
|
|
PTDEBUG && _d('Reordered', $key->{name}, 'cols from',
|
|
$key->{colnames}, 'to', $ordered_cols);
|
|
$key->{colnames} = $ordered_cols;
|
|
}
|
|
|
|
my $push_to = $key->{is_unique} ? \@unique_keys : \@normal_keys;
|
|
if ( !$args{ignore_structure} ) {
|
|
$push_to = \@fulltext_keys if $is_fulltext;
|
|
}
|
|
push @$push_to, $key;
|
|
}
|
|
|
|
push @normal_keys, $self->unconstrain_keys($primary_key, \@unique_keys);
|
|
|
|
if ( $primary_key ) {
|
|
PTDEBUG && _d('Comparing PRIMARY KEY to UNIQUE keys');
|
|
push @dupes,
|
|
$self->remove_prefix_duplicates([$primary_key], \@unique_keys, %args);
|
|
|
|
PTDEBUG && _d('Comparing PRIMARY KEY to normal keys');
|
|
push @dupes,
|
|
$self->remove_prefix_duplicates([$primary_key], \@normal_keys, %args);
|
|
}
|
|
|
|
PTDEBUG && _d('Comparing UNIQUE keys to normal keys');
|
|
push @dupes,
|
|
$self->remove_prefix_duplicates(\@unique_keys, \@normal_keys, %args);
|
|
|
|
PTDEBUG && _d('Comparing normal keys');
|
|
push @dupes,
|
|
$self->remove_prefix_duplicates(\@normal_keys, \@normal_keys, %args);
|
|
|
|
PTDEBUG && _d('Comparing FULLTEXT keys');
|
|
push @dupes,
|
|
$self->remove_prefix_duplicates(\@fulltext_keys, \@fulltext_keys, %args, exact_duplicates => 1);
|
|
|
|
|
|
my $clustered_key = $args{clustered_key} ? $keys{$args{clustered_key}}
|
|
: undef;
|
|
PTDEBUG && _d('clustered key:', $clustered_key->{name},
|
|
$clustered_key->{colnames});
|
|
if ( $clustered_key
|
|
&& $args{clustered}
|
|
&& $args{tbl_info}->{engine}
|
|
&& $args{tbl_info}->{engine} =~ m/InnoDB/i )
|
|
{
|
|
PTDEBUG && _d('Removing UNIQUE dupes of clustered key');
|
|
push @dupes,
|
|
$self->remove_clustered_duplicates($clustered_key, \@unique_keys, %args);
|
|
|
|
PTDEBUG && _d('Removing ordinary dupes of clustered key');
|
|
push @dupes,
|
|
$self->remove_clustered_duplicates($clustered_key, \@normal_keys, %args);
|
|
}
|
|
|
|
return \@dupes;
|
|
}
|
|
|
|
sub get_duplicate_fks {
|
|
my ( $self, $fks, %args ) = @_;
|
|
die "I need a fks argument" unless $fks;
|
|
my @fks = values %$fks;
|
|
my @dupes;
|
|
|
|
foreach my $i ( 0..$#fks - 1 ) {
|
|
next unless $fks[$i];
|
|
foreach my $j ( $i+1..$#fks ) {
|
|
next unless $fks[$j];
|
|
|
|
my $i_cols = join(',', sort @{$fks[$i]->{cols}} );
|
|
my $j_cols = join(',', sort @{$fks[$j]->{cols}} );
|
|
my $i_pcols = join(',', sort @{$fks[$i]->{parent_cols}} );
|
|
my $j_pcols = join(',', sort @{$fks[$j]->{parent_cols}} );
|
|
|
|
if ( $fks[$i]->{parent_tblname} eq $fks[$j]->{parent_tblname}
|
|
&& $i_cols eq $j_cols
|
|
&& $i_pcols eq $j_pcols ) {
|
|
my $dupe = {
|
|
key => $fks[$j]->{name},
|
|
cols => [ @{$fks[$j]->{cols}} ],
|
|
ddl => $fks[$j]->{ddl},
|
|
duplicate_of => $fks[$i]->{name},
|
|
duplicate_of_cols => [ @{$fks[$i]->{cols}} ],
|
|
duplicate_of_ddl => $fks[$i]->{ddl},
|
|
reason =>
|
|
"FOREIGN KEY $fks[$j]->{name} ($fks[$j]->{colnames}) "
|
|
. "REFERENCES $fks[$j]->{parent_tblname} "
|
|
. "($fks[$j]->{parent_colnames}) "
|
|
. 'is a duplicate of '
|
|
. "FOREIGN KEY $fks[$i]->{name} ($fks[$i]->{colnames}) "
|
|
. "REFERENCES $fks[$i]->{parent_tblname} "
|
|
."($fks[$i]->{parent_colnames})",
|
|
dupe_type => 'fk',
|
|
};
|
|
push @dupes, $dupe;
|
|
delete $fks[$j];
|
|
$args{callback}->($dupe, %args) if $args{callback};
|
|
}
|
|
}
|
|
}
|
|
return \@dupes;
|
|
}
|
|
|
|
sub remove_prefix_duplicates {
|
|
my ( $self, $left_keys, $right_keys, %args ) = @_;
|
|
my @dupes;
|
|
my $right_offset;
|
|
my $last_left_key;
|
|
my $last_right_key = scalar(@$right_keys) - 1;
|
|
|
|
|
|
if ( $right_keys != $left_keys ) {
|
|
|
|
@$left_keys = sort { lc($a->{colnames}) cmp lc($b->{colnames}) }
|
|
grep { defined $_; }
|
|
@$left_keys;
|
|
@$right_keys = sort { lc($a->{colnames}) cmp lc($b->{colnames}) }
|
|
grep { defined $_; }
|
|
@$right_keys;
|
|
|
|
$last_left_key = scalar(@$left_keys) - 1;
|
|
|
|
$right_offset = 0;
|
|
}
|
|
else {
|
|
|
|
@$left_keys = reverse sort { lc($a->{colnames}) cmp lc($b->{colnames}) }
|
|
grep { defined $_; }
|
|
@$left_keys;
|
|
|
|
$last_left_key = scalar(@$left_keys) - 2;
|
|
|
|
$right_offset = 1;
|
|
}
|
|
|
|
LEFT_KEY:
|
|
foreach my $left_index ( 0..$last_left_key ) {
|
|
next LEFT_KEY unless defined $left_keys->[$left_index];
|
|
|
|
RIGHT_KEY:
|
|
foreach my $right_index ( $left_index+$right_offset..$last_right_key ) {
|
|
next RIGHT_KEY unless defined $right_keys->[$right_index];
|
|
|
|
my $left_name = $left_keys->[$left_index]->{name};
|
|
my $left_cols = $left_keys->[$left_index]->{colnames};
|
|
my $left_len_cols = $left_keys->[$left_index]->{len_cols};
|
|
my $right_name = $right_keys->[$right_index]->{name};
|
|
my $right_cols = $right_keys->[$right_index]->{colnames};
|
|
my $right_len_cols = $right_keys->[$right_index]->{len_cols};
|
|
|
|
PTDEBUG && _d('Comparing left', $left_name, '(',$left_cols,')',
|
|
'to right', $right_name, '(',$right_cols,')');
|
|
|
|
if ( substr($left_cols, 0, $right_len_cols)
|
|
eq substr($right_cols, 0, $right_len_cols) ) {
|
|
|
|
if ( $args{exact_duplicates} && ($right_len_cols<$left_len_cols) ) {
|
|
PTDEBUG && _d($right_name, 'not exact duplicate of', $left_name);
|
|
next RIGHT_KEY;
|
|
}
|
|
|
|
if ( exists $right_keys->[$right_index]->{unique_col} ) {
|
|
PTDEBUG && _d('Cannot remove', $right_name,
|
|
'because is constrains col',
|
|
$right_keys->[$right_index]->{cols}->[0]);
|
|
next RIGHT_KEY;
|
|
}
|
|
|
|
PTDEBUG && _d('Remove', $right_name);
|
|
my $reason;
|
|
if ( $right_keys->[$right_index]->{unconstrained} ) {
|
|
$reason .= "Uniqueness of $right_name ignored because "
|
|
. $right_keys->[$right_index]->{constraining_key}->{name}
|
|
. " is a stronger constraint\n";
|
|
}
|
|
my $exact_dupe = $right_len_cols < $left_len_cols ? 0 : 1;
|
|
$reason .= $right_name
|
|
. ($exact_dupe ? ' is a duplicate of '
|
|
: ' is a left-prefix of ')
|
|
. $left_name;
|
|
my $dupe = {
|
|
key => $right_name,
|
|
cols => $right_keys->[$right_index]->{real_cols},
|
|
ddl => $right_keys->[$right_index]->{ddl},
|
|
duplicate_of => $left_name,
|
|
duplicate_of_cols => $left_keys->[$left_index]->{real_cols},
|
|
duplicate_of_ddl => $left_keys->[$left_index]->{ddl},
|
|
reason => $reason,
|
|
dupe_type => $exact_dupe ? 'exact' : 'prefix',
|
|
};
|
|
push @dupes, $dupe;
|
|
delete $right_keys->[$right_index];
|
|
|
|
$args{callback}->($dupe, %args) if $args{callback};
|
|
}
|
|
else {
|
|
PTDEBUG && _d($right_name, 'not left-prefix of', $left_name);
|
|
next LEFT_KEY;
|
|
}
|
|
} # RIGHT_KEY
|
|
} # LEFT_KEY
|
|
PTDEBUG && _d('No more keys');
|
|
|
|
@$left_keys = grep { defined $_; } @$left_keys;
|
|
@$right_keys = grep { defined $_; } @$right_keys;
|
|
|
|
return @dupes;
|
|
}
|
|
|
|
sub remove_clustered_duplicates {
|
|
my ( $self, $ck, $keys, %args ) = @_;
|
|
die "I need a ck argument" unless $ck;
|
|
die "I need a keys argument" unless $keys;
|
|
my $ck_cols = $ck->{colnames};
|
|
|
|
my @dupes;
|
|
KEY:
|
|
for my $i ( 0 .. @$keys - 1 ) {
|
|
my $key = $keys->[$i]->{colnames};
|
|
if ( $key =~ m/$ck_cols$/ ) {
|
|
PTDEBUG && _d("clustered key dupe:", $keys->[$i]->{name},
|
|
$keys->[$i]->{colnames});
|
|
my $dupe = {
|
|
key => $keys->[$i]->{name},
|
|
cols => $keys->[$i]->{real_cols},
|
|
ddl => $keys->[$i]->{ddl},
|
|
duplicate_of => $ck->{name},
|
|
duplicate_of_cols => $ck->{real_cols},
|
|
duplicate_of_ddl => $ck->{ddl},
|
|
reason => "Key $keys->[$i]->{name} ends with a "
|
|
. "prefix of the clustered index",
|
|
dupe_type => 'clustered',
|
|
short_key => $self->shorten_clustered_duplicate(
|
|
$ck_cols,
|
|
join(',', map { "`$_`" }
|
|
@{$keys->[$i]->{real_cols}})
|
|
),
|
|
};
|
|
push @dupes, $dupe;
|
|
delete $keys->[$i];
|
|
$args{callback}->($dupe, %args) if $args{callback};
|
|
}
|
|
}
|
|
PTDEBUG && _d('No more keys');
|
|
|
|
@$keys = grep { defined $_; } @$keys;
|
|
|
|
return @dupes;
|
|
}
|
|
|
|
sub shorten_clustered_duplicate {
|
|
my ( $self, $ck_cols, $dupe_key_cols ) = @_;
|
|
return $ck_cols if $ck_cols eq $dupe_key_cols;
|
|
$dupe_key_cols =~ s/$ck_cols$//;
|
|
$dupe_key_cols =~ s/,+$//;
|
|
return $dupe_key_cols;
|
|
}
|
|
|
|
sub unconstrain_keys {
|
|
my ( $self, $primary_key, $unique_keys ) = @_;
|
|
die "I need a unique_keys argument" unless $unique_keys;
|
|
my %unique_cols;
|
|
my @unique_sets;
|
|
my %unconstrain;
|
|
my @unconstrained_keys;
|
|
|
|
PTDEBUG && _d('Unconstraining redundantly unique keys');
|
|
|
|
UNIQUE_KEY:
|
|
foreach my $unique_key ( $primary_key, @$unique_keys ) {
|
|
next unless $unique_key; # primary key may be undefined
|
|
my $cols = $unique_key->{cols};
|
|
if ( @$cols == 1 ) {
|
|
PTDEBUG && _d($unique_key->{name},'defines unique column:',$cols->[0]);
|
|
if ( !exists $unique_cols{$cols->[0]} ) {
|
|
$unique_cols{$cols->[0]} = $unique_key;
|
|
$unique_key->{unique_col} = 1;
|
|
}
|
|
}
|
|
else {
|
|
local $LIST_SEPARATOR = '-';
|
|
PTDEBUG && _d($unique_key->{name}, 'defines unique set:', @$cols);
|
|
push @unique_sets, { cols => $cols, key => $unique_key };
|
|
}
|
|
}
|
|
|
|
UNIQUE_SET:
|
|
foreach my $unique_set ( @unique_sets ) {
|
|
my $n_unique_cols = 0;
|
|
COL:
|
|
foreach my $col ( @{$unique_set->{cols}} ) {
|
|
if ( exists $unique_cols{$col} ) {
|
|
PTDEBUG && _d('Unique set', $unique_set->{key}->{name},
|
|
'has unique col', $col);
|
|
last COL if ++$n_unique_cols > 1;
|
|
$unique_set->{constraining_key} = $unique_cols{$col};
|
|
}
|
|
}
|
|
if ( $n_unique_cols && $unique_set->{key}->{name} ne 'PRIMARY' ) {
|
|
PTDEBUG && _d('Will unconstrain unique set',
|
|
$unique_set->{key}->{name},
|
|
'because it is redundantly constrained by key',
|
|
$unique_set->{constraining_key}->{name},
|
|
'(',$unique_set->{constraining_key}->{colnames},')');
|
|
$unconstrain{$unique_set->{key}->{name}}
|
|
= $unique_set->{constraining_key};
|
|
}
|
|
}
|
|
|
|
for my $i ( 0..(scalar @$unique_keys-1) ) {
|
|
if ( exists $unconstrain{$unique_keys->[$i]->{name}} ) {
|
|
PTDEBUG && _d('Unconstraining', $unique_keys->[$i]->{name});
|
|
$unique_keys->[$i]->{unconstrained} = 1;
|
|
$unique_keys->[$i]->{constraining_key}
|
|
= $unconstrain{$unique_keys->[$i]->{name}};
|
|
push @unconstrained_keys, $unique_keys->[$i];
|
|
delete $unique_keys->[$i];
|
|
}
|
|
}
|
|
|
|
PTDEBUG && _d('No more keys');
|
|
return @unconstrained_keys;
|
|
}
|
|
|
|
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 DuplicateKeyFinder package
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# Daemon package
|
|
# This package is a copy without comments from the original. The original
|
|
# with comments and its test file can be found in the Bazaar repository at,
|
|
# lib/Daemon.pm
|
|
# t/lib/Daemon.t
|
|
# See https://launchpad.net/percona-toolkit for more information.
|
|
# ###########################################################################
|
|
{
|
|
package Daemon;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
use POSIX qw(setsid);
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
foreach my $arg ( qw(o) ) {
|
|
die "I need a $arg argument" unless $args{$arg};
|
|
}
|
|
my $o = $args{o};
|
|
my $self = {
|
|
o => $o,
|
|
log_file => $o->has('log') ? $o->get('log') : undef,
|
|
PID_file => $o->has('pid') ? $o->get('pid') : undef,
|
|
};
|
|
|
|
check_PID_file(undef, $self->{PID_file});
|
|
|
|
PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
|
|
return bless $self, $class;
|
|
}
|
|
|
|
sub daemonize {
|
|
my ( $self ) = @_;
|
|
|
|
PTDEBUG && _d('About to fork and daemonize');
|
|
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
|
|
if ( $pid ) {
|
|
PTDEBUG && _d('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";
|
|
}
|
|
}
|
|
|
|
PTDEBUG && _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;
|
|
PTDEBUG && _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;
|
|
PTDEBUG && _d('PID file exists; it contains PID', $pid);
|
|
if ( $pid ) {
|
|
my $pid_is_alive = kill 0, $pid;
|
|
if ( $pid_is_alive ) {
|
|
die "The PID file $PID_file already exists "
|
|
. " and the PID that it contains, $pid, is running";
|
|
}
|
|
else {
|
|
warn "Overwriting PID file $PID_file because the PID that it "
|
|
. "contains, $pid, is not running";
|
|
}
|
|
}
|
|
else {
|
|
die "The PID file $PID_file already exists but it does not "
|
|
. "contain a PID";
|
|
}
|
|
}
|
|
else {
|
|
PTDEBUG && _d('No PID file');
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub make_PID_file {
|
|
my ( $self ) = @_;
|
|
if ( exists $self->{child} ) {
|
|
die "Do not call Daemon::make_PID_file() for daemonized scripts";
|
|
}
|
|
$self->_make_PID_file();
|
|
$self->{PID_owner} = $PID;
|
|
return;
|
|
}
|
|
|
|
sub _make_PID_file {
|
|
my ( $self ) = @_;
|
|
|
|
my $PID_file = $self->{PID_file};
|
|
if ( !$PID_file ) {
|
|
PTDEBUG && _d('No PID file to create');
|
|
return;
|
|
}
|
|
|
|
$self->check_PID_file();
|
|
|
|
open my $PID_FH, '>', $PID_file
|
|
or die "Cannot open PID file $PID_file: $OS_ERROR";
|
|
print $PID_FH $PID
|
|
or die "Cannot print to PID file $PID_file: $OS_ERROR";
|
|
close $PID_FH
|
|
or die "Cannot close PID file $PID_file: $OS_ERROR";
|
|
|
|
PTDEBUG && _d('Created PID file:', $self->{PID_file});
|
|
return;
|
|
}
|
|
|
|
sub _remove_PID_file {
|
|
my ( $self ) = @_;
|
|
if ( $self->{PID_file} && -f $self->{PID_file} ) {
|
|
unlink $self->{PID_file}
|
|
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
|
|
PTDEBUG && _d('Removed PID file');
|
|
}
|
|
else {
|
|
PTDEBUG && _d('No PID to remove');
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub DESTROY {
|
|
my ( $self ) = @_;
|
|
|
|
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
|
|
|
|
return;
|
|
}
|
|
|
|
sub _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
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# Schema 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/Schema.pm
|
|
# t/lib/Schema.t
|
|
# See https://launchpad.net/percona-toolkit for more information.
|
|
# ###########################################################################
|
|
{
|
|
package Schema;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 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,
|
|
schema => {}, # keyed on db->tbl
|
|
};
|
|
return bless $self, $class;
|
|
}
|
|
|
|
sub get_schema {
|
|
my ( $self ) = @_;
|
|
return $self->{schema};
|
|
}
|
|
|
|
sub get_table {
|
|
my ( $self, $db_name, $tbl_name ) = @_;
|
|
if ( exists $self->{schema}->{$db_name}
|
|
&& exists $self->{schema}->{$db_name}->{$tbl_name} ) {
|
|
return $self->{schema}->{$db_name}->{$tbl_name};
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
|
|
sub add_schema_object {
|
|
my ( $self, $schema_object ) = @_;
|
|
die "I need a schema_object argument" unless $schema_object;
|
|
|
|
my ($db, $tbl) = @{$schema_object}{qw(db tbl)};
|
|
if ( !$db || !$tbl ) {
|
|
warn "No database or table for schema object";
|
|
return;
|
|
}
|
|
|
|
my $tbl_struct = $schema_object->{tbl_struct};
|
|
if ( !$tbl_struct ) {
|
|
warn "No table structure for $db.$tbl";
|
|
return;
|
|
}
|
|
|
|
$self->{schema}->{lc $db}->{lc $tbl} = $schema_object;
|
|
|
|
|
|
return;
|
|
}
|
|
|
|
sub find_column {
|
|
my ( $self, %args ) = @_;
|
|
my $ignore = $args{ignore};
|
|
my $schema = $self->{schema};
|
|
|
|
my ($col, $tbl, $db);
|
|
if ( my $col_name = $args{col_name} ) {
|
|
($col, $tbl, $db) = reverse map { s/`//g; $_ } split /[.]/, $col_name;
|
|
PTDEBUG && _d('Column', $col_name, 'has db', $db, 'tbl', $tbl,
|
|
'col', $col);
|
|
}
|
|
else {
|
|
($col, $tbl, $db) = @args{qw(col tbl db)};
|
|
}
|
|
|
|
$db = lc $db;
|
|
$tbl = lc $tbl;
|
|
$col = lc $col;
|
|
|
|
if ( !$col ) {
|
|
PTDEBUG && _d('No column specified or parsed');
|
|
return;
|
|
}
|
|
PTDEBUG && _d('Finding column', $col, 'in', $db, $tbl);
|
|
|
|
if ( $db && !$schema->{$db} ) {
|
|
PTDEBUG && _d('Database', $db, 'does not exist');
|
|
return;
|
|
}
|
|
|
|
if ( $db && $tbl && !$schema->{$db}->{$tbl} ) {
|
|
PTDEBUG && _d('Table', $tbl, 'does not exist in database', $db);
|
|
return;
|
|
}
|
|
|
|
my @tbls;
|
|
my @search_dbs = $db ? ($db) : keys %$schema;
|
|
DATABASE:
|
|
foreach my $search_db ( @search_dbs ) {
|
|
my @search_tbls = $tbl ? ($tbl) : keys %{$schema->{$search_db}};
|
|
|
|
TABLE:
|
|
foreach my $search_tbl ( @search_tbls ) {
|
|
next DATABASE unless exists $schema->{$search_db}->{$search_tbl};
|
|
|
|
if ( $ignore
|
|
&& grep { $_->{db} eq $search_db && $_->{tbl} eq $search_tbl }
|
|
@$ignore ) {
|
|
PTDEBUG && _d('Ignoring', $search_db, $search_tbl, $col);
|
|
next TABLE;
|
|
}
|
|
|
|
my $tbl = $schema->{$search_db}->{$search_tbl};
|
|
if ( $tbl->{tbl_struct}->{is_col}->{$col} ) {
|
|
PTDEBUG && _d('Column', $col, 'exists in', $tbl->{db}, $tbl->{tbl});
|
|
push @tbls, $tbl;
|
|
}
|
|
}
|
|
}
|
|
|
|
return \@tbls;
|
|
}
|
|
|
|
sub find_table {
|
|
my ( $self, %args ) = @_;
|
|
my $ignore = $args{ignore};
|
|
my $schema = $self->{schema};
|
|
|
|
my ($tbl, $db);
|
|
if ( my $tbl_name = $args{tbl_name} ) {
|
|
($tbl, $db) = reverse map { s/`//g; $_ } split /[.]/, $tbl_name;
|
|
PTDEBUG && _d('Table', $tbl_name, 'has db', $db, 'tbl', $tbl);
|
|
}
|
|
else {
|
|
($tbl, $db) = @args{qw(tbl db)};
|
|
}
|
|
|
|
$db = lc $db;
|
|
$tbl = lc $tbl;
|
|
|
|
if ( !$tbl ) {
|
|
PTDEBUG && _d('No table specified or parsed');
|
|
return;
|
|
}
|
|
PTDEBUG && _d('Finding table', $tbl, 'in', $db);
|
|
|
|
if ( $db && !$schema->{$db} ) {
|
|
PTDEBUG && _d('Database', $db, 'does not exist');
|
|
return;
|
|
}
|
|
|
|
if ( $db && $tbl && !$schema->{$db}->{$tbl} ) {
|
|
PTDEBUG && _d('Table', $tbl, 'does not exist in database', $db);
|
|
return;
|
|
}
|
|
|
|
my @dbs;
|
|
my @search_dbs = $db ? ($db) : keys %$schema;
|
|
DATABASE:
|
|
foreach my $search_db ( @search_dbs ) {
|
|
if ( $ignore && grep { $_->{db} eq $search_db } @$ignore ) {
|
|
PTDEBUG && _d('Ignoring', $search_db);
|
|
next DATABASE;
|
|
}
|
|
|
|
if ( exists $schema->{$search_db}->{$tbl} ) {
|
|
PTDEBUG && _d('Table', $tbl, 'exists in', $search_db);
|
|
push @dbs, $search_db;
|
|
}
|
|
}
|
|
|
|
return \@dbs;
|
|
}
|
|
|
|
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 Schema package
|
|
# ###########################################################################
|
|
|
|
# ###########################################################################
|
|
# SchemaIterator 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/SchemaIterator.pm
|
|
# t/lib/SchemaIterator.t
|
|
# See https://launchpad.net/percona-toolkit for more information.
|
|
# ###########################################################################
|
|
{
|
|
package SchemaIterator;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
use Data::Dumper;
|
|
$Data::Dumper::Indent = 1;
|
|
$Data::Dumper::Sortkeys = 1;
|
|
$Data::Dumper::Quotekeys = 0;
|
|
|
|
my $open_comment = qr{/\*!\d{5} };
|
|
my $tbl_name = qr{
|
|
CREATE\s+
|
|
(?:TEMPORARY\s+)?
|
|
TABLE\s+
|
|
(?:IF NOT EXISTS\s+)?
|
|
([^\(]+)
|
|
}x;
|
|
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
my @required_args = qw(OptionParser Quoter);
|
|
foreach my $arg ( @required_args ) {
|
|
die "I need a $arg argument" unless $args{$arg};
|
|
}
|
|
|
|
my ($file_itr, $dbh) = @args{qw(file_itr dbh)};
|
|
die "I need either a dbh or file_itr argument"
|
|
if (!$dbh && !$file_itr) || ($dbh && $file_itr);
|
|
|
|
my $self = {
|
|
%args,
|
|
filters => _make_filters(%args),
|
|
};
|
|
|
|
return bless $self, $class;
|
|
}
|
|
|
|
sub _make_filters {
|
|
my ( %args ) = @_;
|
|
my @required_args = qw(OptionParser Quoter);
|
|
foreach my $arg ( @required_args ) {
|
|
die "I need a $arg argument" unless $args{$arg};
|
|
}
|
|
my ($o, $q) = @args{@required_args};
|
|
|
|
my %filters;
|
|
|
|
|
|
my @simple_filters = qw(
|
|
databases tables engines
|
|
ignore-databases ignore-tables ignore-engines);
|
|
FILTER:
|
|
foreach my $filter ( @simple_filters ) {
|
|
if ( $o->has($filter) ) {
|
|
my $objs = $o->get($filter);
|
|
next FILTER unless $objs && scalar keys %$objs;
|
|
my $is_table = $filter =~ m/table/ ? 1 : 0;
|
|
foreach my $obj ( keys %$objs ) {
|
|
die "Undefined value for --$filter" unless $obj;
|
|
$obj = lc $obj;
|
|
if ( $is_table ) {
|
|
my ($db, $tbl) = $q->split_unquote($obj);
|
|
$db ||= '*';
|
|
PTDEBUG && _d('Filter', $filter, 'value:', $db, $tbl);
|
|
$filters{$filter}->{$tbl} = $db;
|
|
}
|
|
else { # database
|
|
PTDEBUG && _d('Filter', $filter, 'value:', $obj);
|
|
$filters{$filter}->{$obj} = 1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
my @regex_filters = qw(
|
|
databases-regex tables-regex
|
|
ignore-databases-regex ignore-tables-regex);
|
|
REGEX_FILTER:
|
|
foreach my $filter ( @regex_filters ) {
|
|
if ( $o->has($filter) ) {
|
|
my $pat = $o->get($filter);
|
|
next REGEX_FILTER unless $pat;
|
|
$filters{$filter} = qr/$pat/;
|
|
PTDEBUG && _d('Filter', $filter, 'value:', $filters{$filter});
|
|
}
|
|
}
|
|
|
|
PTDEBUG && _d('Schema object filters:', Dumper(\%filters));
|
|
return \%filters;
|
|
}
|
|
|
|
sub next_schema_object {
|
|
my ( $self ) = @_;
|
|
|
|
my $schema_obj;
|
|
if ( $self->{file_itr} ) {
|
|
$schema_obj= $self->_iterate_files();
|
|
}
|
|
else { # dbh
|
|
$schema_obj= $self->_iterate_dbh();
|
|
}
|
|
|
|
if ( $schema_obj ) {
|
|
if ( $schema_obj->{ddl} && $self->{TableParser} ) {
|
|
$schema_obj->{tbl_struct}
|
|
= $self->{TableParser}->parse($schema_obj->{ddl});
|
|
}
|
|
|
|
delete $schema_obj->{ddl} unless $self->{keep_ddl};
|
|
|
|
if ( my $schema = $self->{Schema} ) {
|
|
$schema->add_schema_object($schema_obj);
|
|
}
|
|
}
|
|
|
|
PTDEBUG && _d('Next schema object:', $schema_obj->{db}, $schema_obj->{tbl});
|
|
return $schema_obj;
|
|
}
|
|
|
|
sub _iterate_files {
|
|
my ( $self ) = @_;
|
|
|
|
if ( !$self->{fh} ) {
|
|
my ($fh, $file) = $self->{file_itr}->();
|
|
if ( !$fh ) {
|
|
PTDEBUG && _d('No more files to iterate');
|
|
return;
|
|
}
|
|
$self->{fh} = $fh;
|
|
$self->{file} = $file;
|
|
}
|
|
my $fh = $self->{fh};
|
|
PTDEBUG && _d('Getting next schema object from', $self->{file});
|
|
|
|
local $INPUT_RECORD_SEPARATOR = '';
|
|
CHUNK:
|
|
while (defined(my $chunk = <$fh>)) {
|
|
if ($chunk =~ m/Database: (\S+)/) {
|
|
my $db = $1; # XXX
|
|
$db =~ s/^`//; # strip leading `
|
|
$db =~ s/`$//; # and trailing `
|
|
if ( $self->database_is_allowed($db) ) {
|
|
$self->{db} = $db;
|
|
}
|
|
}
|
|
elsif ($self->{db} && $chunk =~ m/CREATE TABLE/) {
|
|
if ($chunk =~ m/DROP VIEW IF EXISTS/) {
|
|
PTDEBUG && _d('Table is a VIEW, skipping');
|
|
next CHUNK;
|
|
}
|
|
|
|
my ($tbl) = $chunk =~ m/$tbl_name/;
|
|
$tbl =~ s/^\s*`//;
|
|
$tbl =~ s/`\s*$//;
|
|
if ( $self->table_is_allowed($self->{db}, $tbl) ) {
|
|
my ($ddl) = $chunk =~ m/^(?:$open_comment)?(CREATE TABLE.+?;)$/ms;
|
|
if ( !$ddl ) {
|
|
warn "Failed to parse CREATE TABLE from\n" . $chunk;
|
|
next CHUNK;
|
|
}
|
|
$ddl =~ s/ \*\/;\Z/;/; # remove end of version comment
|
|
|
|
my ($engine) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
|
|
|
|
if ( !$engine || $self->engine_is_allowed($engine) ) {
|
|
return {
|
|
db => $self->{db},
|
|
tbl => $tbl,
|
|
ddl => $ddl,
|
|
};
|
|
}
|
|
}
|
|
}
|
|
} # CHUNK
|
|
|
|
PTDEBUG && _d('No more schema objects in', $self->{file});
|
|
close $self->{fh};
|
|
$self->{fh} = undef;
|
|
|
|
return $self->_iterate_files();
|
|
}
|
|
|
|
sub _iterate_dbh {
|
|
my ( $self ) = @_;
|
|
my $q = $self->{Quoter};
|
|
my $dbh = $self->{dbh};
|
|
PTDEBUG && _d('Getting next schema object from dbh', $dbh);
|
|
|
|
if ( !defined $self->{dbs} ) {
|
|
my $sql = 'SHOW DATABASES';
|
|
PTDEBUG && _d($sql);
|
|
my @dbs = grep { $self->database_is_allowed($_) }
|
|
@{$dbh->selectcol_arrayref($sql)};
|
|
PTDEBUG && _d('Found', scalar @dbs, 'databases');
|
|
$self->{dbs} = \@dbs;
|
|
}
|
|
|
|
if ( !$self->{db} ) {
|
|
$self->{db} = shift @{$self->{dbs}};
|
|
PTDEBUG && _d('Next database:', $self->{db});
|
|
return unless $self->{db};
|
|
}
|
|
|
|
if ( !defined $self->{tbls} ) {
|
|
my $sql = 'SHOW /*!50002 FULL*/ TABLES FROM ' . $q->quote($self->{db});
|
|
PTDEBUG && _d($sql);
|
|
my @tbls = map {
|
|
$_->[0]; # (tbl, type)
|
|
}
|
|
grep {
|
|
my ($tbl, $type) = @$_;
|
|
$self->table_is_allowed($self->{db}, $tbl)
|
|
&& (!$type || ($type ne 'VIEW'));
|
|
}
|
|
@{$dbh->selectall_arrayref($sql)};
|
|
PTDEBUG && _d('Found', scalar @tbls, 'tables in database', $self->{db});
|
|
$self->{tbls} = \@tbls;
|
|
}
|
|
|
|
while ( my $tbl = shift @{$self->{tbls}} ) {
|
|
my $engine;
|
|
if ( $self->{filters}->{'engines'}
|
|
|| $self->{filters}->{'ignore-engines'} ) {
|
|
my $sql = "SHOW TABLE STATUS FROM " . $q->quote($self->{db})
|
|
. " LIKE \'$tbl\'";
|
|
PTDEBUG && _d($sql);
|
|
$engine = $dbh->selectrow_hashref($sql)->{engine};
|
|
PTDEBUG && _d($tbl, 'uses', $engine, 'engine');
|
|
}
|
|
|
|
|
|
if ( !$engine || $self->engine_is_allowed($engine) ) {
|
|
my $ddl;
|
|
if ( my $du = $self->{MySQLDump} ) {
|
|
$ddl = $du->get_create_table($dbh, $q, $self->{db}, $tbl)->[1];
|
|
}
|
|
|
|
return {
|
|
db => $self->{db},
|
|
tbl => $tbl,
|
|
ddl => $ddl,
|
|
};
|
|
}
|
|
}
|
|
|
|
PTDEBUG && _d('No more tables in database', $self->{db});
|
|
$self->{db} = undef;
|
|
$self->{tbls} = undef;
|
|
|
|
return $self->_iterate_dbh();
|
|
}
|
|
|
|
sub database_is_allowed {
|
|
my ( $self, $db ) = @_;
|
|
die "I need a db argument" unless $db;
|
|
|
|
$db = lc $db;
|
|
|
|
my $filter = $self->{filters};
|
|
|
|
if ( $db =~ m/information_schema|performance_schema|lost\+found/ ) {
|
|
PTDEBUG && _d('Database', $db, 'is a system database, ignoring');
|
|
return 0;
|
|
}
|
|
|
|
if ( $self->{filters}->{'ignore-databases'}->{$db} ) {
|
|
PTDEBUG && _d('Database', $db, 'is in --ignore-databases list');
|
|
return 0;
|
|
}
|
|
|
|
if ( $filter->{'ignore-databases-regex'}
|
|
&& $db =~ $filter->{'ignore-databases-regex'} ) {
|
|
PTDEBUG && _d('Database', $db, 'matches --ignore-databases-regex');
|
|
return 0;
|
|
}
|
|
|
|
if ( $filter->{'databases'}
|
|
&& !$filter->{'databases'}->{$db} ) {
|
|
PTDEBUG && _d('Database', $db, 'is not in --databases list, ignoring');
|
|
return 0;
|
|
}
|
|
|
|
if ( $filter->{'databases-regex'}
|
|
&& $db !~ $filter->{'databases-regex'} ) {
|
|
PTDEBUG && _d('Database', $db, 'does not match --databases-regex, ignoring');
|
|
return 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub table_is_allowed {
|
|
my ( $self, $db, $tbl ) = @_;
|
|
die "I need a db argument" unless $db;
|
|
die "I need a tbl argument" unless $tbl;
|
|
|
|
$db = lc $db;
|
|
$tbl = lc $tbl;
|
|
|
|
my $filter = $self->{filters};
|
|
|
|
if ( $filter->{'ignore-tables'}->{$tbl}
|
|
&& ($filter->{'ignore-tables'}->{$tbl} eq '*'
|
|
|| $filter->{'ignore-tables'}->{$tbl} eq $db) ) {
|
|
PTDEBUG && _d('Table', $tbl, 'is in --ignore-tables list');
|
|
return 0;
|
|
}
|
|
|
|
if ( $filter->{'ignore-tables-regex'}
|
|
&& $tbl =~ $filter->{'ignore-tables-regex'} ) {
|
|
PTDEBUG && _d('Table', $tbl, 'matches --ignore-tables-regex');
|
|
return 0;
|
|
}
|
|
|
|
if ( $filter->{'tables'}
|
|
&& !$filter->{'tables'}->{$tbl} ) {
|
|
PTDEBUG && _d('Table', $tbl, 'is not in --tables list, ignoring');
|
|
return 0;
|
|
}
|
|
|
|
if ( $filter->{'tables-regex'}
|
|
&& $tbl !~ $filter->{'tables-regex'} ) {
|
|
PTDEBUG && _d('Table', $tbl, 'does not match --tables-regex, ignoring');
|
|
return 0;
|
|
}
|
|
|
|
if ( $filter->{'tables'}
|
|
&& $filter->{'tables'}->{$tbl}
|
|
&& $filter->{'tables'}->{$tbl} ne '*'
|
|
&& $filter->{'tables'}->{$tbl} ne $db ) {
|
|
PTDEBUG && _d('Table', $tbl, 'is only allowed in database',
|
|
$filter->{'tables'}->{$tbl});
|
|
return 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub engine_is_allowed {
|
|
my ( $self, $engine ) = @_;
|
|
die "I need an engine argument" unless $engine;
|
|
|
|
$engine = lc $engine;
|
|
|
|
my $filter = $self->{filters};
|
|
|
|
if ( $filter->{'ignore-engines'}->{$engine} ) {
|
|
PTDEBUG && _d('Engine', $engine, 'is in --ignore-databases list');
|
|
return 0;
|
|
}
|
|
|
|
if ( $filter->{'engines'}
|
|
&& !$filter->{'engines'}->{$engine} ) {
|
|
PTDEBUG && _d('Engine', $engine, 'is not in --engines list, ignoring');
|
|
return 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
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 SchemaIterator 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_duplicate_key_checker;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
use List::Util qw(max);
|
|
|
|
$OUTPUT_AUTOFLUSH = 1;
|
|
|
|
my $max_width = 74;
|
|
my $hdr_width = $max_width - 2; # for '# '
|
|
my $hdr_fmt = "# %-${hdr_width}s\n";
|
|
|
|
sub main {
|
|
@ARGV = @_; # set global ARGV for this package
|
|
|
|
my %summary = ( 'Total Indexes' => 0 );
|
|
my %seen_tbl;
|
|
|
|
my $q = new Quoter();
|
|
my $tp = new TableParser(Quoter => $q);
|
|
|
|
# #######################################################################
|
|
# Get configuration information and parse command line options.
|
|
# #######################################################################
|
|
my $o = new OptionParser();
|
|
$o->get_specs();
|
|
$o->get_opts();
|
|
|
|
my $dp = $o->DSNParser();
|
|
$dp->prop('set-vars', $o->get('set-vars'));
|
|
|
|
$o->usage_or_errors();
|
|
|
|
# ########################################################################
|
|
# If --pid, check it first since we'll die if it already exits.
|
|
# ########################################################################
|
|
my $daemon;
|
|
if ( $o->get('pid') ) {
|
|
# We're not daemoninzing, it just handles PID stuff. Keep $daemon
|
|
# in the the scope of main() because when it's destroyed it automatically
|
|
# removes the PID file.
|
|
$daemon = new Daemon(o=>$o);
|
|
$daemon->make_PID_file();
|
|
}
|
|
|
|
# #######################################################################
|
|
# Connect to MySQL.
|
|
# #######################################################################
|
|
if ( $o->got('ask-pass') ) {
|
|
$o->set('password', OptionParser::prompt_noecho("Enter password: "));
|
|
}
|
|
my $dsn_defaults = $dp->parse_options($o);
|
|
my $dsn = @ARGV ? $dp->parse(shift @ARGV, $dsn_defaults)
|
|
: $dsn_defaults;
|
|
my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn),
|
|
{ AutoCommit => 1, });
|
|
|
|
my $vp = new VersionParser();
|
|
my $version = $vp->parse($dbh->selectrow_array('SELECT VERSION()'));
|
|
|
|
# #######################################################################
|
|
# Do the main work.
|
|
# #######################################################################
|
|
my $ks = $o->get('summary') ? new KeySize(q=>$q) : undef;
|
|
my $dk = new DuplicateKeyFinder();
|
|
my $du = new MySQLDump();
|
|
|
|
my %tp_opts = (
|
|
ignore_type => $o->get('all-structs'),
|
|
ignore_order => $o->get('ignore-order'),
|
|
clustered => $o->get('clustered'),
|
|
);
|
|
|
|
my $get_keys = $o->get('key-types') =~ m/k/ ? 1 : 0;
|
|
my $get_fks = $o->get('key-types') =~ m/f/ ? 1 : 0;
|
|
|
|
my $schema = new Schema();
|
|
my $schema_itr = new SchemaIterator(
|
|
dbh => $dbh,
|
|
OptionParser => $o,
|
|
Quoter => $q,
|
|
MySQLDump => $du,
|
|
TableParser => $tp,
|
|
Schema => $schema,
|
|
keep_ddl => 1,
|
|
);
|
|
TABLE:
|
|
while ( my $tbl = $schema_itr->next_schema_object() ) {
|
|
$tbl->{engine} = $tp->get_engine($tbl->{ddl});
|
|
|
|
my ($keys, $clustered_key, $fks);
|
|
if ( $get_keys ) {
|
|
($keys, $clustered_key)
|
|
= $tp->get_keys($tbl->{ddl}, {version => $version});
|
|
}
|
|
if ( $get_fks ) {
|
|
$fks = $tp->get_fks($tbl->{ddl}, {database => $tbl->{db}});
|
|
}
|
|
|
|
next TABLE unless %$keys || %$fks;
|
|
|
|
if ( $o->got('verbose') ) {
|
|
print_all_keys($keys, $tbl, \%seen_tbl) if $keys;
|
|
print_all_keys($fks, $tbl, \%seen_tbl) if $fks;
|
|
}
|
|
else {
|
|
PTDEBUG && _d('Getting duplicate keys on', $tbl->{db}, $tbl->{tbl});
|
|
eval {
|
|
if ( $keys ) {
|
|
$dk->get_duplicate_keys(
|
|
$keys,
|
|
clustered_key => $clustered_key,
|
|
tbl_info => $tbl,
|
|
callback => \&print_duplicate_key,
|
|
%tp_opts,
|
|
# get_duplicate_keys() ignores these args but passes them
|
|
# to the callback:
|
|
dbh => $dbh,
|
|
is_fk => 0,
|
|
o => $o,
|
|
ks => $ks,
|
|
tp => $tp,
|
|
q => $q,
|
|
seen_tbl => \%seen_tbl,
|
|
summary => \%summary,
|
|
);
|
|
}
|
|
if ( $fks ) {
|
|
$dk->get_duplicate_fks(
|
|
$fks,
|
|
tbl_info => $tbl,
|
|
callback => \&print_duplicate_key,
|
|
%tp_opts,
|
|
# get_duplicate_fks() ignores these args but passes them
|
|
# to the callback:
|
|
dbh => $dbh,
|
|
is_fk => 1,
|
|
o => $o,
|
|
ks => $ks,
|
|
tp => $tp,
|
|
q => $q,
|
|
seen_tbl => \%seen_tbl,
|
|
summary => \%summary,
|
|
);
|
|
}
|
|
};
|
|
if ( $EVAL_ERROR ) {
|
|
warn "Error checking `$tbl->{db}`.`$tbl->{tbl}` for duplicate keys: "
|
|
. $EVAL_ERROR;
|
|
next TABLE;
|
|
}
|
|
}
|
|
|
|
# Always count Total Keys so print_key_summary won't die
|
|
# because %summary is empty.
|
|
$summary{'Total Indexes'} += (scalar keys %$keys) + (scalar keys %$fks)
|
|
} # TABLE
|
|
|
|
print_key_summary(%summary) if $o->get('summary');
|
|
|
|
return 0;
|
|
}
|
|
|
|
# ##########################################################################
|
|
# Subroutines
|
|
# ##########################################################################
|
|
|
|
sub print_all_keys {
|
|
my ( $keys, $tbl_info, $seen_tbl ) = @_;
|
|
return unless $keys;
|
|
my $db = $tbl_info->{db};
|
|
my $tbl = $tbl_info->{tbl};
|
|
if ( !$seen_tbl->{"$db$tbl"}++ ) {
|
|
printf $hdr_fmt, ('#' x $hdr_width);
|
|
printf $hdr_fmt, "$db.$tbl";
|
|
printf $hdr_fmt, ('#' x $hdr_width);
|
|
}
|
|
foreach my $key ( values %$keys ) {
|
|
print "\n# $key->{name} ($key->{colnames})";
|
|
}
|
|
print "\n";
|
|
return;
|
|
}
|
|
|
|
sub print_duplicate_key {
|
|
my ( $dupe, %args ) = @_;
|
|
return unless $dupe;
|
|
foreach my $arg ( qw(tbl_info dbh is_fk o ks q tp seen_tbl) ) {
|
|
die "I need a $arg argument" unless exists $args{$arg};
|
|
}
|
|
PTDEBUG && _d('Printing duplicate key', $dupe->{key});
|
|
my $db = $args{tbl_info}->{db};
|
|
my $tbl = $args{tbl_info}->{tbl};
|
|
my $dbh = $args{dbh};
|
|
my $o = $args{o};
|
|
my $ks = $args{ks};
|
|
my $seen_tbl = $args{seen_tbl};
|
|
my $q = $args{q};
|
|
my $tp = $args{tp};
|
|
my $summary = $args{summary};
|
|
my $struct = $tp->parse($args{tbl_info}->{ddl});
|
|
|
|
if ( !$seen_tbl->{"$db$tbl"}++ ) {
|
|
printf $hdr_fmt, ('#' x $hdr_width);
|
|
printf $hdr_fmt, "$db.$tbl";
|
|
printf $hdr_fmt, ('#' x $hdr_width);
|
|
print "\n";
|
|
}
|
|
|
|
$dupe->{reason} =~ s/\n/\n# /g;
|
|
print "# $dupe->{reason}\n";
|
|
|
|
print "# Key definitions:\n";
|
|
print "# " . ($dupe->{ddl} || '') . "\n";
|
|
print "# " . ($dupe->{duplicate_of_ddl} || '') . "\n";
|
|
|
|
print "# Column types:\n";
|
|
my %seen; # print each column only once
|
|
foreach my $col ( @{$dupe->{cols}}, @{$dupe->{duplicate_of_cols}} ) {
|
|
next if $seen{$col}++;
|
|
PTDEBUG && _d('col', $col);
|
|
print "#\t" . lc($struct->{defs}->{lc $col}) . "\n";
|
|
}
|
|
|
|
if ( $o->get('sql') ) {
|
|
if ( $dupe->{dupe_type} ne 'clustered' ) {
|
|
print "# To remove this duplicate "
|
|
. ($args{is_fk} ? 'foreign key' : 'index')
|
|
. ", execute:\n"
|
|
. 'ALTER TABLE ' . $q->quote($db, $tbl)
|
|
. ($args{is_fk} ? ' DROP FOREIGN KEY ' : ' DROP INDEX ')
|
|
. "`$dupe->{key}`;\n";
|
|
}
|
|
else {
|
|
# Suggest shortening clustered dupes instead of
|
|
# removing them (issue 295).
|
|
print "# To shorten this duplicate clustered index, execute:\n"
|
|
. 'ALTER TABLE '.$q->quote($db, $tbl)." DROP INDEX `$dupe->{key}`, "
|
|
. "ADD INDEX `$dupe->{key}` ($dupe->{short_key});\n";
|
|
}
|
|
}
|
|
print "\n";
|
|
|
|
if ( $o->get('summary') && $summary ) {
|
|
$summary->{'Total Duplicate Indexes'} += 1;
|
|
my ($size, $chosen_key) = $ks->get_key_size(
|
|
name => $dupe->{key},
|
|
cols => $dupe->{cols},
|
|
tbl_name => $q->quote($db, $tbl),
|
|
tbl_struct => $struct,
|
|
dbh => $dbh,
|
|
);
|
|
if ( $args{is_fk} ) {
|
|
# Foreign keys have no size because they're just constraints.
|
|
print "# MySQL uses the $chosen_key index for this "
|
|
. "foreign key constraint\n\n";
|
|
}
|
|
else {
|
|
$size ||= 0;
|
|
|
|
# Create Size Duplicate Keys summary even if there's no valid keys.
|
|
$summary->{'Size Duplicate Indexes'} += $size;
|
|
|
|
if ( $size ) {
|
|
if ( $chosen_key && $chosen_key ne $dupe->{key} ) {
|
|
# This shouldn't happen. But in case it does, we should know.
|
|
print "# MySQL chose the $chosen_key index despite FORCE INDEX\n\n";
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub print_key_summary {
|
|
my ( %summary ) = @_;
|
|
printf $hdr_fmt, ('#' x $hdr_width);
|
|
printf $hdr_fmt, 'Summary of indexes';
|
|
printf $hdr_fmt, ('#' x $hdr_width);
|
|
print "\n";
|
|
my $max_item = max(map { length($_) } keys %summary);
|
|
my $line_fmt = "# %-${max_item}s %-s\n";
|
|
foreach my $item ( sort keys %summary ) {
|
|
printf $line_fmt, $item, $summary{$item};
|
|
}
|
|
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";
|
|
}
|
|
|
|
# ############################################################################
|
|
# Run the program.
|
|
# ############################################################################
|
|
if ( !caller ) { exit main(@ARGV); }
|
|
|
|
1; # Because this is a module as well as a script.
|
|
|
|
# ############################################################################
|
|
# Documentation
|
|
# ############################################################################
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
pt-duplicate-key-checker - Find duplicate indexes and foreign keys on MySQL tables.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
Usage: pt-duplicate-key-checker [OPTION...] [DSN]
|
|
|
|
pt-duplicate-key-checker examines MySQL tables for duplicate or redundant
|
|
indexes and foreign keys. Connection options are read from MySQL option files.
|
|
|
|
pt-duplicate-key-checker --host host1
|
|
|
|
=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-duplicate-key-checker is a read-only tool that executes SHOW CREATE TABLE and
|
|
related queries to inspect table structures, and thus is very low-risk.
|
|
|
|
At the time of this release, there is an unconfirmed bug that causes the tool
|
|
to crash.
|
|
|
|
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-duplicate-key-checker>.
|
|
|
|
See also L<"BUGS"> for more information on filing bugs and getting help.
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This program examines the output of SHOW CREATE TABLE on MySQL tables, and if
|
|
it finds indexes that cover the same columns as another index in the same
|
|
order, or cover an exact leftmost prefix of another index, it prints out
|
|
the suspicious indexes. By default, indexes must be of the same type, so a
|
|
BTREE index is not a duplicate of a FULLTEXT index, even if they have the same
|
|
columns. You can override this.
|
|
|
|
It also looks for duplicate foreign keys. A duplicate foreign key covers the
|
|
same columns as another in the same table, and references the same parent
|
|
table.
|
|
|
|
=head1 OPTIONS
|
|
|
|
This tool accepts additional command-line arguments. Refer to the
|
|
L<"SYNOPSIS"> and usage information for details.
|
|
|
|
=over
|
|
|
|
=item --all-structs
|
|
|
|
Compare indexes with different structs (BTREE, HASH, etc).
|
|
|
|
By default this is disabled, because a BTREE index that covers the same columns
|
|
as a FULLTEXT index is not really a duplicate, for example.
|
|
|
|
=item --ask-pass
|
|
|
|
Prompt for a password when connecting to MySQL.
|
|
|
|
=item --charset
|
|
|
|
short form: -A; type: string
|
|
|
|
Default character set. If the value is utf8, sets Perl's binmode on
|
|
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET
|
|
NAMES UTF8 after connecting to MySQL. Any other value sets binmode on STDOUT
|
|
without the utf8 layer, and runs SET NAMES after connecting to MySQL.
|
|
|
|
=item --[no]clustered
|
|
|
|
default: yes
|
|
|
|
PK columns appended to secondary key is duplicate.
|
|
|
|
Detects when a suffix of a secondary key is a leftmost prefix of the primary
|
|
key, and treats it as a duplicate key. Only detects this condition on storage
|
|
engines whose primary keys are clustered (currently InnoDB and solidDB).
|
|
|
|
Clustered storage engines append the primary key columns to the leaf nodes of
|
|
all secondary keys anyway, so you might consider it redundant to have them
|
|
appear in the internal nodes as well. Of course, you may also want them in the
|
|
internal nodes, because just having them at the leaf nodes won't help for some
|
|
queries. It does help for covering index queries, however.
|
|
|
|
Here's an example of a key that is considered redundant with this option:
|
|
|
|
PRIMARY KEY (`a`)
|
|
KEY `b` (`b`,`a`)
|
|
|
|
The use of such indexes is rather subtle. For example, suppose you have the
|
|
following query:
|
|
|
|
SELECT ... WHERE b=1 ORDER BY a;
|
|
|
|
This query will do a filesort if we remove the index on C<b,a>. But if we
|
|
shorten the index on C<b,a> to just C<b> and also remove the ORDER BY, the query
|
|
should return the same results.
|
|
|
|
The tool suggests shortening duplicate clustered keys by dropping the key
|
|
and re-adding it without the primary key prefix. The shortened clustered
|
|
key may still duplicate another key, but the tool cannot currently detect
|
|
when this happens without being ran a second time to re-check the newly
|
|
shortened clustered keys. Therefore, if you shorten any duplicate clustered
|
|
keys, you should run the tool again.
|
|
|
|
=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 --databases
|
|
|
|
short form: -d; type: hash
|
|
|
|
Check only this comma-separated list of databases.
|
|
|
|
=item --defaults-file
|
|
|
|
short form: -F; type: string
|
|
|
|
Only read mysql options from the given file. You must give an absolute pathname.
|
|
|
|
=item --engines
|
|
|
|
short form: -e; type: hash
|
|
|
|
Check only tables whose storage engine is in this comma-separated list.
|
|
|
|
=item --help
|
|
|
|
Show help and exit.
|
|
|
|
=item --host
|
|
|
|
short form: -h; type: string
|
|
|
|
Connect to host.
|
|
|
|
=item --ignore-databases
|
|
|
|
type: Hash
|
|
|
|
Ignore this comma-separated list of databases.
|
|
|
|
=item --ignore-engines
|
|
|
|
type: Hash
|
|
|
|
Ignore this comma-separated list of storage engines.
|
|
|
|
=item --ignore-order
|
|
|
|
Ignore index order so KEY(a,b) duplicates KEY(b,a).
|
|
|
|
=item --ignore-tables
|
|
|
|
type: Hash
|
|
|
|
Ignore this comma-separated list of tables. Table names may be qualified with
|
|
the database name.
|
|
|
|
=item --key-types
|
|
|
|
type: string; default: fk
|
|
|
|
Check for duplicate f=foreign keys, k=keys or fk=both.
|
|
|
|
=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 script.
|
|
The PID file is removed when the script exits. Before starting, the script
|
|
checks if the PID file already exists. If it does not, then the script creates
|
|
and writes its own PID to it. If it does, then the script checks the following:
|
|
if the file contains a PID and a process is running with that PID, then
|
|
the script dies; or, if there is no process running with that PID, then the
|
|
script overwrites the file with its own PID and starts; else, if the file
|
|
contains no PID, then the script dies.
|
|
|
|
=item --port
|
|
|
|
short form: -P; type: int
|
|
|
|
Port number to use for connection.
|
|
|
|
=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 --socket
|
|
|
|
short form: -S; type: string
|
|
|
|
Socket file to use for connection.
|
|
|
|
=item --[no]sql
|
|
|
|
default: yes
|
|
|
|
Print DROP KEY statement for each duplicate key. By default an ALTER TABLE
|
|
DROP KEY statement is printed below each duplicate key so that, if you want to
|
|
remove the duplicate key, you can copy-paste the statement into MySQL.
|
|
|
|
To disable printing these statements, specify --nosql.
|
|
|
|
=item --[no]summary
|
|
|
|
default: yes
|
|
|
|
Print summary of indexes at end of output.
|
|
|
|
=item --tables
|
|
|
|
short form: -t; type: hash
|
|
|
|
Check only this comma-separated list of tables.
|
|
|
|
Table names may be qualified with the database name.
|
|
|
|
=item --user
|
|
|
|
short form: -u; type: string
|
|
|
|
User for login if not current user.
|
|
|
|
=item --verbose
|
|
|
|
short form: -v
|
|
|
|
Output all keys and/or foreign keys found, not just redundant ones.
|
|
|
|
=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
|
|
|
|
Default database.
|
|
|
|
=item * F
|
|
|
|
dsn: mysql_read_default_file; copy: yes
|
|
|
|
Only read default options from the given file
|
|
|
|
=item * h
|
|
|
|
dsn: host; copy: yes
|
|
|
|
Connect to host.
|
|
|
|
=item * p
|
|
|
|
dsn: password; copy: yes
|
|
|
|
Password to use when connecting.
|
|
|
|
=item * P
|
|
|
|
dsn: port; copy: yes
|
|
|
|
Port number to use for connection.
|
|
|
|
=item * S
|
|
|
|
dsn: mysql_socket; copy: yes
|
|
|
|
Socket file to use for connection.
|
|
|
|
=item * u
|
|
|
|
dsn: user; copy: yes
|
|
|
|
User for login if not current user.
|
|
|
|
=back
|
|
|
|
=head1 ENVIRONMENT
|
|
|
|
The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
|
|
To enable debugging and capture all output to a file, run the tool like:
|
|
|
|
PTDEBUG=1 pt-duplicate-key-checker ... > 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-duplicate-key-checker>.
|
|
|
|
Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
|
|
Include the following information in your bug report:
|
|
|
|
=over
|
|
|
|
=item * Complete command-line used to run the tool
|
|
|
|
=item * Tool L<"--version">
|
|
|
|
=item * MySQL version of all servers involved
|
|
|
|
=item * Output from the tool including STDERR
|
|
|
|
=item * Input files (log/dump/config files, etc.)
|
|
|
|
=back
|
|
|
|
If possible, include debugging output by running the tool with C<PTDEBUG>;
|
|
see L<"ENVIRONMENT">.
|
|
|
|
=head1 DOWNLOADING
|
|
|
|
Visit L<http://www.percona.com/software/percona-toolkit/> to download the
|
|
latest release of Percona Toolkit. Or, get the latest release from the
|
|
command line:
|
|
|
|
wget percona.com/get/percona-toolkit.tar.gz
|
|
|
|
wget percona.com/get/percona-toolkit.rpm
|
|
|
|
wget percona.com/get/percona-toolkit.deb
|
|
|
|
You can also get individual tools from the latest release:
|
|
|
|
wget percona.com/get/TOOL
|
|
|
|
Replace C<TOOL> with the name of any tool.
|
|
|
|
=head1 AUTHORS
|
|
|
|
Baron Schwartz and Daniel Nichter
|
|
|
|
=head1 ABOUT PERCONA TOOLKIT
|
|
|
|
This tool is part of Percona Toolkit, a collection of advanced command-line
|
|
tools 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 2007-2011 Baron Schwartz, 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-duplicate-key-checker 2.0.1
|
|
|
|
=cut
|