percona/percona-toolkit
1
0
Fork 0
mirror of https://github.com/percona/percona-toolkit.git synced 2025-09-02 02:34:19 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
aac8b6a85ae1474dd87b0e5d76ade802d17c89f3
percona-toolkit/bin/pt-index-usage
Dmitriy Kostiuk aac8b6a85a Fix PT-1605, 3.0 version, documenting data collected... (#359) 
* Fix PT-1605, 3.0 version, documenting data collected with --version-check

* Made text more general and less PT based
2018-08-30 23:30:10 +03:00

7679 lines
223 KiB
Perl
Executable File
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

#!/usr/bin/env perl
# This program is part of Percona Toolkit: http://www.percona.com/software/
# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
# notices and disclaimers.
use strict;
use warnings FATAL => 'all';
# This tool is "fat-packed": most of its dependent modules are embedded
# in this file. Setting %INC to this file for each module makes Perl aware
# of this so it will not try to load the module from @INC. See the tool's
# documentation for a full list of dependencies.
BEGIN {
$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
Percona::Toolkit
DSNParser
Quoter
OptionParser
PodParser
QueryParser
QueryRewriter
SlowLogParser
TableParser
Transformers
Schema
SchemaIterator
FileIterator
ExplainAnalyzer
IndexUsage
Progress
HTTP::Micro
VersionCheck
));
}
# ###########################################################################
# Percona::Toolkit package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Percona/Toolkit.pm
# t/lib/Percona/Toolkit.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Percona::Toolkit;
our $VERSION = '3.0.11-dev';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Carp qw(carp cluck);
use Data::Dumper qw();
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
have_required_args
Dumper
_d
);
sub have_required_args {
my ($args, @required_args) = @_;
my $have_required_args = 1;
foreach my $arg ( @required_args ) {
if ( !defined $args->{$arg} ) {
$have_required_args = 0;
carp "Argument $arg is not defined";
}
}
cluck unless $have_required_args; # print backtrace
return $have_required_args;
}
sub Dumper {
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
Data::Dumper::Dumper(@_);
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Percona::Toolkit package
# ###########################################################################
# ###########################################################################
# DSNParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DSNParser.pm
# t/lib/DSNParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DSNParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Quotekeys = 0;
my $dsn_sep = qr/(?<!\\),/;
eval {
require DBI;
};
my $have_dbi = $EVAL_ERROR ? 0 : 1;
sub new {
my ( $class, %args ) = @_;
foreach my $arg ( qw(opts) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
};
foreach my $opt ( @{$args{opts}} ) {
if ( !$opt->{key} || !$opt->{desc} ) {
die "Invalid DSN option: ", Dumper($opt);
}
PTDEBUG && _d('DSN option:',
join(', ',
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
keys %$opt
)
);
$self->{opts}->{$opt->{key}} = {
dsn => $opt->{dsn},
desc => $opt->{desc},
copy => $opt->{copy} || 0,
};
}
return bless $self, $class;
}
sub prop {
my ( $self, $prop, $value ) = @_;
if ( @_ > 2 ) {
PTDEBUG && _d('Setting', $prop, 'property');
$self->{$prop} = $value;
}
return $self->{$prop};
}
sub parse {
my ( $self, $dsn, $prev, $defaults ) = @_;
if ( !$dsn ) {
PTDEBUG && _d('No DSN to parse');
return;
}
PTDEBUG && _d('Parsing', $dsn);
$prev ||= {};
$defaults ||= {};
my %given_props;
my %final_props;
my $opts = $self->{opts};
foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
$dsn_part =~ s/\\,/,/g;
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
$given_props{$prop_key} = $prop_val;
}
else {
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
$given_props{h} = $dsn_part;
}
}
foreach my $key ( keys %$opts ) {
PTDEBUG && _d('Finding value for', $key);
$final_props{$key} = $given_props{$key};
if ( !defined $final_props{$key}
&& defined $prev->{$key} && $opts->{$key}->{copy} )
{
$final_props{$key} = $prev->{$key};
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
}
if ( !defined $final_props{$key} ) {
$final_props{$key} = $defaults->{$key};
PTDEBUG && _d('Copying value for', $key, 'from defaults');
}
}
foreach my $key ( keys %given_props ) {
die "Unknown DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless exists $opts->{$key};
}
if ( (my $required = $self->prop('required')) ) {
foreach my $key ( keys %$required ) {
die "Missing required DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless $final_props{$key};
}
}
return \%final_props;
}
sub parse_options {
my ( $self, $o ) = @_;
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
my $dsn_string
= join(',',
map { "$_=".$o->get($_); }
grep { $o->has($_) && $o->get($_) }
keys %{$self->{opts}}
);
PTDEBUG && _d('DSN string made from options:', $dsn_string);
return $self->parse($dsn_string);
}
sub as_string {
my ( $self, $dsn, $props ) = @_;
return $dsn unless ref $dsn;
my @keys = $props ? @$props : sort keys %$dsn;
return join(',',
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
grep {
exists $self->{opts}->{$_}
&& exists $dsn->{$_}
&& defined $dsn->{$_}
} @keys);
}
sub usage {
my ( $self ) = @_;
my $usage
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
. " KEY COPY MEANING\n"
. " === ==== =============================================\n";
my %opts = %{$self->{opts}};
foreach my $key ( sort keys %opts ) {
$usage .= " $key "
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
. ($opts{$key}->{desc} || '[No description]')
. "\n";
}
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
return $usage;
}
sub get_cxn_params {
my ( $self, $info ) = @_;
my $dsn;
my %opts = %{$self->{opts}};
my $driver = $self->prop('dbidriver') || '';
if ( $driver eq 'Pg' ) {
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(h P));
}
else {
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(F h P S A))
. ';mysql_read_default_group=client'
. ($info->{L} ? ';mysql_local_infile=1' : '');
}
PTDEBUG && _d($dsn);
return ($dsn, $info->{u}, $info->{p});
}
sub fill_in_dsn {
my ( $self, $dbh, $dsn ) = @_;
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
$user =~ s/@.*//;
$dsn->{h} ||= $vars->{hostname}->{Value};
$dsn->{S} ||= $vars->{'socket'}->{Value};
$dsn->{P} ||= $vars->{port}->{Value};
$dsn->{u} ||= $user;
$dsn->{D} ||= $db;
}
sub get_dbh {
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
$opts ||= {};
my $defaults = {
AutoCommit => 0,
RaiseError => 1,
PrintError => 0,
ShowErrorStatement => 1,
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
};
@{$defaults}{ keys %$opts } = values %$opts;
if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
$defaults->{mysql_local_infile} = 1;
}
if ( $opts->{mysql_use_result} ) {
$defaults->{mysql_use_result} = 1;
}
if ( !$have_dbi ) {
die "Cannot connect to MySQL because the Perl DBI module is not "
. "installed or not found. Run 'perl -MDBI' to see the directories "
. "that Perl searches for DBI. If DBI is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbi-perl\n"
. " RHEL/CentOS yum install perl-DBI\n"
. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
}
my $dbh;
my $tries = 2;
while ( !$dbh && $tries-- ) {
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
if ( !$dbh && $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
. "the directories that Perl searches for DBD::mysql. If "
. "DBD::mysql is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
}
elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
PTDEBUG && _d('Going to try again without utf8 support');
delete $defaults->{mysql_enable_utf8};
}
if ( !$tries ) {
die $EVAL_ERROR;
}
}
}
if ( $cxn_string =~ m/mysql/i ) {
my $sql;
if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
$sql = qq{/*!40101 SET NAMES "$charset"*/};
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting NAMES to $charset: $EVAL_ERROR";
}
PTDEBUG && _d('Enabling charset for STDOUT');
if ( $charset eq 'utf8' ) {
binmode(STDOUT, ':utf8')
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
}
else {
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
}
}
if ( my $vars = $self->prop('set-vars') ) {
$self->set_vars($dbh, $vars);
}
$sql = 'SELECT @@SQL_MODE';
PTDEBUG && _d($dbh, $sql);
my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
die "Error getting the current SQL_MODE: $EVAL_ERROR";
}
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
. ($sql_mode ? ",$sql_mode" : '')
. '\'*/';
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
. ($sql_mode ? " and $sql_mode" : '')
. ": $EVAL_ERROR";
}
}
PTDEBUG && _d('DBH info: ',
$dbh,
Dumper($dbh->selectrow_hashref(
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
'Connection info:', $dbh->{mysql_hostinfo},
'Character set info:', Dumper($dbh->selectall_arrayref(
"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
'$DBI::VERSION:', $DBI::VERSION,
);
return $dbh;
}
sub get_hostname {
my ( $self, $dbh ) = @_;
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
return $host;
}
my ( $hostname, $one ) = $dbh->selectrow_array(
'SELECT /*!50038 @@hostname, */ 1');
return $hostname;
}
sub disconnect {
my ( $self, $dbh ) = @_;
PTDEBUG && $self->print_active_handles($dbh);
$dbh->disconnect;
}
sub print_active_handles {
my ( $self, $thing, $level ) = @_;
$level ||= 0;
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
or die "Cannot print: $OS_ERROR";
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
$self->print_active_handles( $handle, $level + 1 );
}
}
sub copy {
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
die 'I need a dsn_1 argument' unless $dsn_1;
die 'I need a dsn_2 argument' unless $dsn_2;
my %new_dsn = map {
my $key = $_;
my $val;
if ( $args{overwrite} ) {
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
}
else {
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
}
$key => $val;
} keys %{$self->{opts}};
return \%new_dsn;
}
sub set_vars {
my ($self, $dbh, $vars) = @_;
return unless $vars;
foreach my $var ( sort keys %$vars ) {
my $val = $vars->{$var}->{val};
(my $quoted_var = $var) =~ s/_/\\_/;
my ($var_exists, $current_val);
eval {
($var_exists, $current_val) = $dbh->selectrow_array(
"SHOW VARIABLES LIKE '$quoted_var'");
};
my $e = $EVAL_ERROR;
if ( $e ) {
PTDEBUG && _d($e);
}
if ( $vars->{$var}->{default} && !$var_exists ) {
PTDEBUG && _d('Not setting default var', $var,
'because it does not exist');
next;
}
if ( $current_val && $current_val eq $val ) {
PTDEBUG && _d('Not setting var', $var, 'because its value',
'is already', $val);
next;
}
my $sql = "SET SESSION $var=$val";
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( my $set_error = $EVAL_ERROR ) {
chomp($set_error);
$set_error =~ s/ at \S+ line \d+//;
my $msg = "Error setting $var: $set_error";
if ( $current_val ) {
$msg .= " The current value for $var is $current_val. "
. "If the variable is read only (not dynamic), specify "
. "--set-vars $var=$current_val to avoid this warning, "
. "else manually set the variable and restart MySQL.";
}
warn $msg . "\n\n";
}
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End DSNParser package
# ###########################################################################
# ###########################################################################
# 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;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 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, %args ) = @_;
return 'NULL' unless defined $val; # undef = NULL
return "''" if $val eq ''; # blank string = ''
return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data
&& !$args{is_char}; # unless is_char is true
$val =~ s/(['\\])/\\$1/g;
return "'$val'";
}
sub split_unquote {
my ( $self, $db_tbl, $default_db ) = @_;
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
for ($db, $tbl) {
next unless $_;
s/\A`//;
s/`\z//;
s/``/`/g;
}
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;
}
sub serialize_list {
my ( $self, @args ) = @_;
PTDEBUG && _d('Serializing', Dumper(\@args));
return unless @args;
my @parts;
foreach my $arg ( @args ) {
if ( defined $arg ) {
$arg =~ s/,/\\,/g; # escape commas
$arg =~ s/\\N/\\\\N/g; # escape literal \N
push @parts, $arg;
}
else {
push @parts, '\N';
}
}
my $string = join(',', @parts);
PTDEBUG && _d('Serialized: <', $string, '>');
return $string;
}
sub deserialize_list {
my ( $self, $string ) = @_;
PTDEBUG && _d('Deserializing <', $string, '>');
die "Cannot deserialize an undefined string" unless defined $string;
my @parts;
foreach my $arg ( split(/(?<!\\),/, $string) ) {
if ( $arg eq '\N' ) {
$arg = undef;
}
else {
$arg =~ s/\\,/,/g;
$arg =~ s/\\\\N/\\N/g;
}
push @parts, $arg;
}
if ( !@parts ) {
my $n_empty_strings = $string =~ tr/,//;
$n_empty_strings++;
PTDEBUG && _d($n_empty_strings, 'empty strings');
map { push @parts, '' } 1..$n_empty_strings;
}
elsif ( $string =~ m/(?<!\\),$/ ) {
PTDEBUG && _d('Last value is an empty string');
push @parts, '';
}
PTDEBUG && _d('Deserialized', Dumper(\@parts));
return @parts;
}
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 Quoter package
# ###########################################################################
# ###########################################################################
# OptionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/OptionParser.pm
# t/lib/OptionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package OptionParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use List::Util qw(max);
use Getopt::Long;
use Data::Dumper;
my $POD_link_re = '[LC]<"?([^">]+)"?>';
sub new {
my ( $class, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
$program_name ||= $PROGRAM_NAME;
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my %attributes = (
'type' => 1,
'short form' => 1,
'group' => 1,
'default' => 1,
'cumulative' => 1,
'negatable' => 1,
'repeatable' => 1, # means it can be specified more than once
);
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'),
attributes => \%attribs
};
}
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_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0;
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
$opt->{group} ||= 'default';
$self->{groups}->{ $opt->{group} }->{$long} = 1;
$opt->{value} = undef;
$opt->{got} = 0;
my ( $type ) = $opt->{spec} =~ m/=(.)/;
$opt->{type} = $type;
PTDEBUG && _d($long, 'type:', $type);
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
$self->{defaults}->{$long} = defined $def ? $def : 1;
PTDEBUG && _d($long, 'default:', $def);
}
if ( $long eq 'config' ) {
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
}
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
$disables{$long} = $dis;
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
}
$self->{opts}->{$long} = $opt;
}
else { # It's an option rule, not a spec.
PTDEBUG && _d('Parsing rule:', $opt);
push @{$self->{rules}}, $opt;
my @participants = $self->_get_participants($opt);
my $rule_ok = 0;
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
$rule_ok = 1;
push @{$self->{mutex}}, \@participants;
PTDEBUG && _d(@participants, 'are mutually exclusive');
}
if ( $opt =~ m/at least one|one and only one/ ) {
$rule_ok = 1;
push @{$self->{atleast1}}, \@participants;
PTDEBUG && _d(@participants, 'require at least one');
}
if ( $opt =~ m/default to/ ) {
$rule_ok = 1;
$self->{defaults_to}->{$participants[0]} = $participants[1];
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
}
if ( $opt =~ m/restricted to option groups/ ) {
$rule_ok = 1;
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
my @groups = split(',', $groups);
%{$self->{allowed_groups}->{$participants[0]}} = map {
s/\s+//;
$_ => 1;
} @groups;
}
if( $opt =~ m/accepts additional command-line arguments/ ) {
$rule_ok = 1;
$self->{strict} = 0;
PTDEBUG && _d("Strict mode disabled by rule");
}
die "Unrecognized option rule: $opt" unless $rule_ok;
}
}
foreach my $long ( keys %disables ) {
my @participants = $self->_get_participants($disables{$long});
$self->{disables}->{$long} = \@participants;
PTDEBUG && _d('Option', $long, 'disables', @participants);
}
return;
}
sub _get_participants {
my ( $self, $str ) = @_;
my @participants;
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
die "Option --$long does not exist while processing rule $str"
unless exists $self->{opts}->{$long};
push @participants, $long;
}
PTDEBUG && _d('Participants for', $str, ':', @participants);
return @participants;
}
sub opts {
my ( $self ) = @_;
my %opts = %{$self->{opts}};
return %opts;
}
sub short_opts {
my ( $self ) = @_;
my %short_opts = %{$self->{short_opts}};
return %short_opts;
}
sub set_defaults {
my ( $self, %defaults ) = @_;
$self->{defaults} = {};
foreach my $long ( keys %defaults ) {
die "Cannot set default for nonexistent option $long"
unless exists $self->{opts}->{$long};
$self->{defaults}->{$long} = $defaults{$long};
PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
}
return;
}
sub get_defaults {
my ( $self ) = @_;
return $self->{defaults};
}
sub get_groups {
my ( $self ) = @_;
return $self->{groups};
}
sub _set_option {
my ( $self, $opt, $val ) = @_;
my $long = exists $self->{opts}->{$opt} ? $opt
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
: die "Getopt::Long gave a nonexistent option: $opt";
$opt = $self->{opts}->{$long};
if ( $opt->{is_cumulative} ) {
$opt->{value}++;
}
elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
my $next_opt = $1;
if ( exists $self->{opts}->{$next_opt}
|| exists $self->{short_opts}->{$next_opt} ) {
$self->save_error("--$long requires a string value");
return;
}
else {
if ($opt->{is_repeatable}) {
push @{$opt->{value}} , $val;
}
else {
$opt->{value} = $val;
}
}
}
else {
if ($opt->{is_repeatable}) {
push @{$opt->{value}} , $val;
}
else {
$opt->{value} = $val;
}
}
$opt->{got} = 1;
PTDEBUG && _d('Got option', $long, '=', $val);
}
sub get_opts {
my ( $self ) = @_;
foreach my $long ( keys %{$self->{opts}} ) {
$self->{opts}->{$long}->{got} = 0;
$self->{opts}->{$long}->{value}
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
: $self->{opts}->{$long}->{is_cumulative} ? 0
: undef;
}
$self->{got_opts} = 0;
$self->{errors} = [];
if ( @ARGV && $ARGV[0] =~/^--config=/ ) {
$ARGV[0] = substr($ARGV[0],9);
$ARGV[0] =~ s/^'(.*)'$/$1/;
$ARGV[0] =~ s/^"(.*)"$/$1/;
$self->_set_option('config', shift @ARGV);
}
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";
exit 0;
}
else {
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
exit 1;
}
}
if ( @ARGV && $self->{strict} ) {
$self->save_error("Unrecognized command-line options @ARGV");
}
foreach my $mutex ( @{$self->{mutex}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
if ( @set > 1 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
. ' are mutually exclusive.';
$self->save_error($err);
}
}
foreach my $required ( @{$self->{atleast1}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
if ( @set == 0 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$required}[ 0 .. scalar(@$required) - 2] )
.' or --'.$self->{opts}->{$required->[-1]}->{long};
$self->save_error("Specify at least one of $err");
}
}
$self->_check_opts( keys %{$self->{opts}} );
$self->{got_opts} = 1;
return;
}
sub _check_opts {
my ( $self, @long ) = @_;
my $long_last = scalar @long;
while ( @long ) {
foreach my $i ( 0..$#long ) {
my $long = $long[$i];
next unless $long;
my $opt = $self->{opts}->{$long};
if ( $opt->{got} ) {
if ( exists $self->{disables}->{$long} ) {
my @disable_opts = @{$self->{disables}->{$long}};
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
PTDEBUG && _d('Unset options', @disable_opts,
'because', $long,'disables them');
}
if ( exists $self->{allowed_groups}->{$long} ) {
my @restricted_groups = grep {
!exists $self->{allowed_groups}->{$long}->{$_}
} keys %{$self->{groups}};
my @restricted_opts;
foreach my $restricted_group ( @restricted_groups ) {
RESTRICTED_OPT:
foreach my $restricted_opt (
keys %{$self->{groups}->{$restricted_group}} )
{
next RESTRICTED_OPT if $restricted_opt eq $long;
push @restricted_opts, $restricted_opt
if $self->{opts}->{$restricted_opt}->{got};
}
}
if ( @restricted_opts ) {
my $err;
if ( @restricted_opts == 1 ) {
$err = "--$restricted_opts[0]";
}
else {
$err = join(', ',
map { "--$self->{opts}->{$_}->{long}" }
grep { $_ }
@restricted_opts[0..scalar(@restricted_opts) - 2]
)
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
}
$self->save_error("--$long is not allowed with $err");
}
}
}
elsif ( $opt->{is_required} ) {
$self->save_error("Required option --$long must be specified");
}
$self->_validate_type($opt);
if ( $opt->{parsed} ) {
delete $long[$i];
}
else {
PTDEBUG && _d('Temporarily failed to parse', $long);
}
}
die "Failed to parse options, possibly due to circular dependencies"
if @long == $long_last;
$long_last = @long;
}
return;
}
sub _validate_type {
my ( $self, $opt ) = @_;
return unless $opt;
if ( !$opt->{type} ) {
$opt->{parsed} = 1;
return;
}
my $val = $opt->{value};
if ( $val && $opt->{type} eq 'm' ) { # type time
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
if ( !$suffix ) {
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
$suffix = $s || 's';
PTDEBUG && _d('No suffix given; using', $suffix, 'for',
$opt->{long}, '(value:', $val, ')');
}
if ( $suffix =~ m/[smhd]/ ) {
$val = $suffix eq 's' ? $num # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$opt->{value} = ($prefix || '') . $val;
PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
}
else {
$self->save_error("Invalid time suffix for --$opt->{long}");
}
}
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
my $prev = {};
my $from_key = $self->{defaults_to}->{ $opt->{long} };
if ( $from_key ) {
PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
if ( $self->{opts}->{$from_key}->{parsed} ) {
$prev = $self->{opts}->{$from_key}->{value};
}
else {
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
$from_key, 'parsed');
return;
}
}
my $defaults = $self->{DSNParser}->parse_options($self);
if (!$opt->{attributes}->{repeatable}) {
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
} else {
my $values = [];
for my $dsn_string (@$val) {
push @$values, $self->{DSNParser}->parse($dsn_string, $prev, $defaults);
}
$opt->{value} = $values;
}
}
elsif ( $val && $opt->{type} eq 'z' ) { # type size
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
$self->_parse_size($opt, $val);
}
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
}
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
}
else {
PTDEBUG && _d('Nothing to validate for option',
$opt->{long}, 'type', $opt->{type}, 'value', $val);
}
$opt->{parsed} = 1;
return;
}
sub get {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{value};
}
sub got {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{got};
}
sub has {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
return defined $long ? exists $self->{opts}->{$long} : 0;
}
sub set {
my ( $self, $opt, $val ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
$self->{opts}->{$long}->{value} = $val;
return;
}
sub save_error {
my ( $self, $error ) = @_;
push @{$self->{errors}}, $error;
return;
}
sub errors {
my ( $self ) = @_;
return $self->{errors};
}
sub usage {
my ( $self ) = @_;
warn "No usage string is set" unless $self->{usage}; # XXX
return "Usage: " . ($self->{usage} || '') . "\n";
}
sub descr {
my ( $self ) = @_;
warn "No description string is set" unless $self->{description}; # XXX
my $descr = ($self->{description} || $self->{program_name} || '')
. " For more details, please use the --help option, "
. "or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation.";
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
unless $ENV{DONT_BREAK_LINES};
$descr =~ s/ +$//mg;
return $descr;
}
sub usage_or_errors {
my ( $self, $file, $return ) = @_;
$file ||= $self->{file} || __FILE__;
if ( !$self->{description} || !$self->{usage} ) {
PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
my %synop = $self->_parse_synopsis($file);
$self->{description} ||= $synop{description};
$self->{usage} ||= $synop{usage};
PTDEBUG && _d("Description:", $self->{description},
"\nUsage:", $self->{usage});
}
if ( $self->{opts}->{help}->{got} ) {
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
exit 0 unless $return;
}
elsif ( scalar @{$self->{errors}} ) {
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
exit 1 unless $return;
}
return;
}
sub print_errors {
my ( $self ) = @_;
my $usage = $self->usage() . "\n";
if ( (my @errors = @{$self->{errors}}) ) {
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
. "\n";
}
return $usage . "\n" . $self->descr();
}
sub print_usage {
my ( $self ) = @_;
die "Run get_opts() before print_usage()" unless $self->{got_opts};
my @opts = values %{$self->{opts}};
my $maxl = max(
map {
length($_->{long}) # option long name
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
}
@opts);
my $maxs = max(0,
map {
length($_)
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
}
values %{$self->{short_opts}});
my $lcol = max($maxl, ($maxs + 3));
my $rcol = 80 - $lcol - 6;
my $rpad = ' ' x ( 80 - $rcol );
$maxs = max($lcol - 3, $maxs);
my $usage = $self->descr() . "\n" . $self->usage();
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
push @groups, 'default';
foreach my $group ( reverse @groups ) {
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
foreach my $opt (
sort { $a->{long} cmp $b->{long} }
grep { $_->{group} eq $group }
@opts )
{
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
my $short = $opt->{short};
my $desc = $opt->{desc};
$long .= $opt->{type} ? "=$opt->{type}" : "";
if ( $opt->{type} && $opt->{type} eq 'm' ) {
my ($s) = $desc =~ m/\(suffix (.)\)/;
$s ||= 's';
$desc =~ s/\s+\(suffix .\)//;
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
. "d=days; if no suffix, $s is used.";
}
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
$desc =~ s/ +$//mg;
if ( $short ) {
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
}
else {
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
}
}
}
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
if ( (my @rules = @{$self->{rules}}) ) {
$usage .= "\nRules:\n\n";
$usage .= join("\n", map { " $_" } @rules) . "\n";
}
if ( $self->{DSNParser} ) {
$usage .= "\n" . $self->{DSNParser}->usage();
}
$usage .= "\nOptions and values after processing arguments:\n\n";
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
my $val = $opt->{value};
my $type = $opt->{type} || '';
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
: !defined $val ? '(No value)'
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
: $type =~ m/H|h/ ? join(',', sort keys %$val)
: $type =~ m/A|a/ ? join(',', @$val)
: $val;
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
}
return $usage;
}
sub prompt_noecho {
shift @_ if ref $_[0] eq __PACKAGE__;
my ( $prompt ) = @_;
local $OUTPUT_AUTOFLUSH = 1;
print STDERR $prompt
or die "Cannot print: $OS_ERROR";
my $response;
eval {
require Term::ReadKey;
Term::ReadKey::ReadMode('noecho');
chomp($response = <STDIN>);
Term::ReadKey::ReadMode('normal');
print "\n"
or die "Cannot print: $OS_ERROR";
};
if ( $EVAL_ERROR ) {
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
}
return $response;
}
sub _read_config_file {
my ( $self, $filename ) = @_;
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
my @args;
my $prefix = '--';
my $parse = 1;
LINE:
while ( my $line = <$fh> ) {
chomp $line;
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
$line =~ s/\s+#.*$//g;
$line =~ s/^\s+|\s+$//g;
if ( $line eq '--' ) {
$prefix = '';
$parse = 0;
next LINE;
}
if ( $parse
&& !$self->has('version-check')
&& $line =~ /version-check/
) {
next LINE;
}
if ( $parse
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
) {
push @args, grep { defined $_ } ("$prefix$opt", $arg);
}
elsif ( $line =~ m/./ ) {
push @args, $line;
}
else {
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
}
}
close $fh;
return @args;
}
sub read_para_after {
my ( $self, $file, $regex ) = @_;
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = '';
my $para;
while ( $para = <$fh> ) {
next unless $para =~ m/^=pod$/m;
last;
}
while ( $para = <$fh> ) {
next unless $para =~ m/$regex/;
last;
}
$para = <$fh>;
chomp($para);
close $fh or die "Can't close $file: $OS_ERROR";
return $para;
}
sub clone {
my ( $self ) = @_;
my %clone = map {
my $hashref = $self->{$_};
my $val_copy = {};
foreach my $key ( keys %$hashref ) {
my $ref = ref $hashref->{$key};
$val_copy->{$key} = !$ref ? $hashref->{$key}
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
: $hashref->{$key};
}
$_ => $val_copy;
} qw(opts short_opts defaults);
foreach my $scalar ( qw(got_opts) ) {
$clone{$scalar} = $self->{$scalar};
}
return bless \%clone;
}
sub _parse_size {
my ( $self, $opt, $val ) = @_;
if ( lc($val || '') eq 'null' ) {
PTDEBUG && _d('NULL size for', $opt->{long});
$opt->{value} = 'null';
return;
}
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
if ( defined $num ) {
if ( $factor ) {
$num *= $factor_for{$factor};
PTDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}: $val");
}
return;
}
sub _parse_attribs {
my ( $self, $option, $attribs ) = @_;
my $types = $self->{types};
return $option
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
. ($attribs->{'negatable'} ? '!' : '' )
. ($attribs->{'cumulative'} ? '+' : '' )
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
}
sub _parse_synopsis {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
die "$file does not contain a SYNOPSIS section" unless $para;
my @synop;
for ( 1..2 ) { # 1 for the usage, 2 for the description
my $para = <$fh>;
push @synop, $para;
}
close $fh;
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
my ($usage, $desc) = @synop;
die "The SYNOPSIS section in $file is not formatted properly"
unless $usage && $desc;
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
chomp $usage;
$desc =~ s/\n/ /g;
$desc =~ s/\s{2,}/ /g;
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
$desc =~ s/\s+$//;
return (
description => $desc,
usage => $usage,
);
};
sub set_vars {
my ($self, $file) = @_;
$file ||= $self->{file} || __FILE__;
my %user_vars;
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
if ( $user_vars ) {
foreach my $var_val ( @$user_vars ) {
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$user_vars{$var} = {
val => $val,
default => 0,
};
}
}
my %default_vars;
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
if ( $default_vars ) {
%default_vars = map {
my $var_val = $_;
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$var => {
val => $val,
default => 1,
};
} split("\n", $default_vars);
}
my %vars = (
%default_vars, # first the tool's defaults
%user_vars, # then the user's which overwrite the defaults
);
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
return \%vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
if ( PTDEBUG ) {
print STDERR '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print STDERR "# $uname\n";
}
print STDERR '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# ###########################################################################
# PodParser 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/PodParser.pm
# t/lib/PodParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package PodParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
my %parse_items_from = (
'OPTIONS' => 1,
'DSN OPTIONS' => 1,
'RULES' => 1,
);
my %item_pattern_for = (
'OPTIONS' => qr/--(.*)/,
'DSN OPTIONS' => qr/\* (.)/,
'RULES' => qr/(.*)/,
);
my %section_has_rules = (
'OPTIONS' => 1,
'DSN OPTIONS' => 0,
'RULES' => 0,
);
sub new {
my ( $class, %args ) = @_;
my $self = {
current_section => '',
current_item => '',
items => {}, # keyed off SECTION
magic => {}, # keyed off SECTION->magic ident (without MAGIC_)
magic_ident => '', # set when next para is a magic para
};
return bless $self, $class;
}
sub get_items {
my ( $self, $section ) = @_;
return $section ? $self->{items}->{$section} : $self->{items};
}
sub get_magic {
my ( $self, $section ) = @_;
return $section ? $self->{magic}->{$section} : $self->{magic};
}
sub parse_from_file {
my ( $self, $file ) = @_;
return unless $file;
PTDEBUG && _d('Parsing POD in', $file);
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=pod/;
die "$file does not contain =pod" unless $para;
while ( defined($para = <$fh>) && $para !~ m/^=cut/ ) {
if ( $para =~ m/^=(head|item|over|back)/ ) {
my ($cmd, $name) = $para =~ m/^=(\w+)(?:\s+(.+))?/;
$name ||= '';
PTDEBUG && _d('cmd:', $cmd, 'name:', $name);
$self->command($cmd, $name);
}
elsif ( $parse_items_from{$self->{current_section}} ) {
$self->textblock($para);
}
}
close $fh;
}
sub command {
my ( $self, $cmd, $name ) = @_;
$name =~ s/\s+\Z//m; # Remove \n and blank line after name.
if ( $cmd eq 'head1' ) {
PTDEBUG && _d('In section', $name);
$self->{current_section} = $name;
}
elsif ( $cmd eq 'over' ) {
if ( $parse_items_from{$name} ) {
PTDEBUG && _d('Start items in', $self->{current_section});
$self->{items}->{$self->{current_section}} = {};
}
}
elsif ( $cmd eq 'item' && $parse_items_from{$self->{current_section}} ) {
my $pat = $item_pattern_for{ $self->{current_section} };
my ($item) = $name =~ m/$pat/;
if ( $item ) {
PTDEBUG && _d($self->{current_section}, 'item:', $item);
$self->{items}->{ $self->{current_section} }->{$item} = {
desc => '', # every item should have a desc
};
$self->{current_item} = $item;
}
else {
warn "Item $name does not match $pat";
}
}
elsif ( $cmd eq 'back' ) {
if ( $parse_items_from{$self->{current_section}} ) {
PTDEBUG && _d('End items in', $self->{current_section});
}
}
else {
$self->{current_section} = '';
}
return;
}
sub textblock {
my ( $self, $para ) = @_;
return unless $self->{current_section} && $self->{current_item};
my $section = $self->{current_section};
my $item = $self->{items}->{$section}->{ $self->{current_item} };
$para =~ s/\s+\Z//;
if ( $para =~ m/^[a-z]\w+[:;] / ) {
PTDEBUG && _d('Item attributes:', $para);
map {
my ($attrib, $val) = split(/: /, $_);
$item->{$attrib} = defined $val ? $val : 1;
} split(/; /, $para);
}
else {
if ( $self->{magic_ident} ) {
my ($leading_space) = $para =~ m/^(\s+)/;
my $indent = length($leading_space || '');
if ( $indent ) {
$para =~ s/^\s{$indent}//mg;
$para =~ s/\s+$//;
PTDEBUG && _d("MAGIC", $self->{magic_ident}, "para:", $para);
$self->{magic}->{$self->{current_section}}->{$self->{magic_ident}}
= $para;
}
else {
PTDEBUG && _d("MAGIC", $self->{magic_ident},
"para is not indented; treating as normal para");
}
$self->{magic_ident} = ''; # must unset this!
}
PTDEBUG && _d('Item desc:', substr($para, 0, 40),
length($para) > 40 ? '...' : '');
$para =~ s/\n+/ /g;
$item->{desc} .= $para;
if ( $para =~ m/MAGIC_(\w+)/ ) {
$self->{magic_ident} = $1; # XXX
PTDEBUG && _d("MAGIC", $self->{magic_ident}, "follows");
}
}
return;
}
sub verbatim {
my ( $self, $para ) = @_;
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 PodParser package
# ###########################################################################
# ###########################################################################
# QueryParser 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/QueryParser.pm
# t/lib/QueryParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package QueryParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
our $tbl_ident = qr/(?:`[^`]+`|\w+)(?:\.(?:`[^`]+`|\w+))?/;
our $tbl_regex = qr{
\b(?:FROM|JOIN|(?<!KEY\s)UPDATE|INTO) # Words that precede table names
\b\s*
\(? # Optional paren around tables
($tbl_ident
(?: (?:\s+ (?:AS\s+)? \w+)?, \s*$tbl_ident )*
)
}xio;
our $has_derived = qr{
\b(?:FROM|JOIN|,)
\s*\(\s*SELECT
}xi;
our $data_def_stmts = qr/(?:CREATE|ALTER|TRUNCATE|DROP|RENAME)/i;
our $data_manip_stmts = qr/(?:INSERT|UPDATE|DELETE|REPLACE)/i;
sub new {
my ( $class ) = @_;
bless {}, $class;
}
sub get_tables {
my ( $self, $query ) = @_;
return unless $query;
PTDEBUG && _d('Getting tables for', $query);
my ( $ddl_stmt ) = $query =~ m/^\s*($data_def_stmts)\b/i;
if ( $ddl_stmt ) {
PTDEBUG && _d('Special table type:', $ddl_stmt);
$query =~ s/IF\s+(?:NOT\s+)?EXISTS//i;
if ( $query =~ m/$ddl_stmt DATABASE\b/i ) {
PTDEBUG && _d('Query alters a database, not a table');
return ();
}
if ( $ddl_stmt =~ m/CREATE/i && $query =~ m/$ddl_stmt\b.+?\bSELECT\b/i ) {
my ($select) = $query =~ m/\b(SELECT\b.+)/is;
PTDEBUG && _d('CREATE TABLE ... SELECT:', $select);
return $self->get_tables($select);
}
my ($tbl) = $query =~ m/TABLE\s+($tbl_ident)(\s+.*)?/i;
PTDEBUG && _d('Matches table:', $tbl);
return ($tbl);
}
$query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;
if ( $query =~ s/^\s*LOCK TABLES\s+//i ) {
PTDEBUG && _d('Special table type: LOCK TABLES');
$query =~ s/\s+(?:READ(?:\s+LOCAL)?|WRITE)\s*//gi;
PTDEBUG && _d('Locked tables:', $query);
$query = "FROM $query";
}
$query =~ s/\\["']//g; # quoted strings
$query =~ s/".*?"/?/sg; # quoted strings
$query =~ s/'.*?'/?/sg; # quoted strings
my @tables;
foreach my $tbls ( $query =~ m/$tbl_regex/gio ) {
PTDEBUG && _d('Match tables:', $tbls);
next if $tbls =~ m/\ASELECT\b/i;
foreach my $tbl ( split(',', $tbls) ) {
$tbl =~ s/\s*($tbl_ident)(\s+.*)?/$1/gio;
if ( $tbl !~ m/[a-zA-Z]/ ) {
PTDEBUG && _d('Skipping suspicious table name:', $tbl);
next;
}
push @tables, $tbl;
}
}
return @tables;
}
sub has_derived_table {
my ( $self, $query ) = @_;
my $match = $query =~ m/$has_derived/;
PTDEBUG && _d($query, 'has ' . ($match ? 'a' : 'no') . ' derived table');
return $match;
}
sub get_aliases {
my ( $self, $query, $list ) = @_;
my $result = {
DATABASE => {},
TABLE => {},
};
return $result unless $query;
$query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;
$query =~ s/ (?:INNER|OUTER|CROSS|LEFT|RIGHT|NATURAL)//ig;
my @tbl_refs;
my ($tbl_refs, $from) = $query =~ m{
(
(FROM|INTO|UPDATE)\b\s* # Keyword before table refs
.+? # Table refs
)
(?:\s+|\z) # If the query does not end with the table
(?:WHERE|ORDER|LIMIT|HAVING|SET|VALUES|\z) # Keyword after table refs
}ix;
if ( $tbl_refs ) {
if ( $query =~ m/^(?:INSERT|REPLACE)/i ) {
$tbl_refs =~ s/\([^\)]+\)\s*//;
}
PTDEBUG && _d('tbl refs:', $tbl_refs);
my $before_tbl = qr/(?:,|JOIN|\s|$from)+/i;
my $after_tbl = qr/(?:,|JOIN|ON|USING|\z)/i;
$tbl_refs =~ s/ = /=/g;
while (
$tbl_refs =~ m{
$before_tbl\b\s*
( ($tbl_ident) (?:\s+ (?:AS\s+)? (\w+))? )
\s*$after_tbl
}xgio )
{
my ( $tbl_ref, $db_tbl, $alias ) = ($1, $2, $3);
PTDEBUG && _d('Match table:', $tbl_ref);
push @tbl_refs, $tbl_ref;
$alias = $self->trim_identifier($alias);
if ( $tbl_ref =~ m/^AS\s+\w+/i ) {
PTDEBUG && _d('Subquery', $tbl_ref);
$result->{TABLE}->{$alias} = undef;
next;
}
my ( $db, $tbl ) = $db_tbl =~ m/^(?:(.*?)\.)?(.*)/;
$db = $self->trim_identifier($db);
$tbl = $self->trim_identifier($tbl);
$result->{TABLE}->{$alias || $tbl} = $tbl;
$result->{DATABASE}->{$tbl} = $db if $db;
}
}
else {
PTDEBUG && _d("No tables ref in", $query);
}
if ( $list ) {
return \@tbl_refs;
}
else {
return $result;
}
}
sub split {
my ( $self, $query ) = @_;
return unless $query;
$query = $self->clean_query($query);
PTDEBUG && _d('Splitting', $query);
my $verbs = qr{SELECT|INSERT|UPDATE|DELETE|REPLACE|UNION|CREATE}i;
my @split_statements = grep { $_ } split(m/\b($verbs\b(?!(?:\s*\()))/io, $query);
my @statements;
if ( @split_statements == 1 ) {
push @statements, $query;
}
else {
for ( my $i = 0; $i <= $#split_statements; $i += 2 ) {
push @statements, $split_statements[$i].$split_statements[$i+1];
if ( $statements[-2] && $statements[-2] =~ m/on duplicate key\s+$/i ) {
$statements[-2] .= pop @statements;
}
}
}
PTDEBUG && _d('statements:', map { $_ ? "<$_>" : 'none' } @statements);
return @statements;
}
sub clean_query {
my ( $self, $query ) = @_;
return unless $query;
$query =~ s!/\*.*?\*/! !g; # Remove /* comment blocks */
$query =~ s/^\s+//; # Remove leading spaces
$query =~ s/\s+$//; # Remove trailing spaces
$query =~ s/\s{2,}/ /g; # Remove extra spaces
return $query;
}
sub split_subquery {
my ( $self, $query ) = @_;
return unless $query;
$query = $self->clean_query($query);
$query =~ s/;$//;
my @subqueries;
my $sqno = 0; # subquery number
my $pos = 0;
while ( $query =~ m/(\S+)(?:\s+|\Z)/g ) {
$pos = pos($query);
my $word = $1;
PTDEBUG && _d($word, $sqno);
if ( $word =~ m/^\(?SELECT\b/i ) {
my $start_pos = $pos - length($word) - 1;
if ( $start_pos ) {
$sqno++;
PTDEBUG && _d('Subquery', $sqno, 'starts at', $start_pos);
$subqueries[$sqno] = {
start_pos => $start_pos,
end_pos => 0,
len => 0,
words => [$word],
lp => 1, # left parentheses
rp => 0, # right parentheses
done => 0,
};
}
else {
PTDEBUG && _d('Main SELECT at pos 0');
}
}
else {
next unless $sqno; # next unless we're in a subquery
PTDEBUG && _d('In subquery', $sqno);
my $sq = $subqueries[$sqno];
if ( $sq->{done} ) {
PTDEBUG && _d('This subquery is done; SQL is for',
($sqno - 1 ? "subquery $sqno" : "the main SELECT"));
next;
}
push @{$sq->{words}}, $word;
my $lp = ($word =~ tr/\(//) || 0;
my $rp = ($word =~ tr/\)//) || 0;
PTDEBUG && _d('parentheses left', $lp, 'right', $rp);
if ( ($sq->{lp} + $lp) - ($sq->{rp} + $rp) == 0 ) {
my $end_pos = $pos - 1;
PTDEBUG && _d('Subquery', $sqno, 'ends at', $end_pos);
$sq->{end_pos} = $end_pos;
$sq->{len} = $end_pos - $sq->{start_pos};
}
}
}
for my $i ( 1..$#subqueries ) {
my $sq = $subqueries[$i];
next unless $sq;
$sq->{sql} = join(' ', @{$sq->{words}});
substr $query,
$sq->{start_pos} + 1, # +1 for (
$sq->{len} - 1, # -1 for )
"__subquery_$i";
}
return $query, map { $_->{sql} } grep { defined $_ } @subqueries;
}
sub query_type {
my ( $self, $query, $qr ) = @_;
my ($type, undef) = $qr->distill_verbs($query);
my $rw;
if ( $type =~ m/^SELECT\b/ ) {
$rw = 'read';
}
elsif ( $type =~ m/^$data_manip_stmts\b/
|| $type =~ m/^$data_def_stmts\b/ ) {
$rw = 'write'
}
return {
type => $type,
rw => $rw,
}
}
sub get_columns {
my ( $self, $query ) = @_;
my $cols = [];
return $cols unless $query;
my $cols_def;
if ( $query =~ m/^SELECT/i ) {
$query =~ s/
^SELECT\s+
(?:ALL
|DISTINCT
|DISTINCTROW
|HIGH_PRIORITY
|STRAIGHT_JOIN
|SQL_SMALL_RESULT
|SQL_BIG_RESULT
|SQL_BUFFER_RESULT
|SQL_CACHE
|SQL_NO_CACHE
|SQL_CALC_FOUND_ROWS
)\s+
/SELECT /xgi;
($cols_def) = $query =~ m/^SELECT\s+(.+?)\s+FROM/i;
}
elsif ( $query =~ m/^(?:INSERT|REPLACE)/i ) {
($cols_def) = $query =~ m/\(([^\)]+)\)\s*VALUE/i;
}
PTDEBUG && _d('Columns:', $cols_def);
if ( $cols_def ) {
@$cols = split(',', $cols_def);
map {
my $col = $_;
$col = s/^\s+//g;
$col = s/\s+$//g;
$col;
} @$cols;
}
return $cols;
}
sub parse {
my ( $self, $query ) = @_;
return unless $query;
my $parsed = {};
$query =~ s/\n/ /g;
$query = $self->clean_query($query);
$parsed->{query} = $query,
$parsed->{tables} = $self->get_aliases($query, 1);
$parsed->{columns} = $self->get_columns($query);
my ($type) = $query =~ m/^(\w+)/;
$parsed->{type} = lc $type;
$parsed->{sub_queries} = [];
return $parsed;
}
sub extract_tables {
my ( $self, %args ) = @_;
my $query = $args{query};
my $default_db = $args{default_db};
my $q = $self->{Quoter} || $args{Quoter};
return unless $query;
PTDEBUG && _d('Extracting tables');
my @tables;
my %seen;
foreach my $db_tbl ( $self->get_tables($query) ) {
next unless $db_tbl;
next if $seen{$db_tbl}++; # Unique-ify for issue 337.
my ( $db, $tbl ) = $q->split_unquote($db_tbl);
push @tables, [ $db || $default_db, $tbl ];
}
return @tables;
}
sub trim_identifier {
my ($self, $str) = @_;
return unless defined $str;
$str =~ s/`//g;
$str =~ s/^\s+//;
$str =~ s/\s+$//;
return $str;
}
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 QueryParser package
# ###########################################################################
# ###########################################################################
# QueryRewriter 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/QueryRewriter.pm
# t/lib/QueryRewriter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package QueryRewriter;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
our $verbs = qr{^SHOW|^FLUSH|^COMMIT|^ROLLBACK|^BEGIN|SELECT|INSERT
|UPDATE|DELETE|REPLACE|^SET|UNION|^START|^LOCK}xi;
my $quote_re = qr/"(?:(?!(?<!\\)").)*"|'(?:(?!(?<!\\)').)*'/; # Costly!
my $bal;
$bal = qr/
\(
(?:
(?> [^()]+ ) # Non-parens without backtracking
|
(??{ $bal }) # Group with matching parens
)*
\)
/x;
my $olc_re = qr/(?:--|#)[^'"\r\n]*(?=[\r\n]|\Z)/; # One-line comments
my $mlc_re = qr#/\*[^!].*?\*/#sm; # But not /*!version */
my $vlc_re = qr#/\*.*?[0-9]+.*?\*/#sm; # For SHOW + /*!version */
my $vlc_rf = qr#^(?:SHOW).*?/\*![0-9]+(.*?)\*/#sm; # Variation for SHOW
sub new {
my ( $class, %args ) = @_;
my $self = { %args };
return bless $self, $class;
}
sub strip_comments {
my ( $self, $query ) = @_;
return unless $query;
$query =~ s/$mlc_re//go;
$query =~ s/$olc_re//go;
if ( $query =~ m/$vlc_rf/i ) { # contains show + version
my $qualifier = $1 || '';
$query =~ s/$vlc_re/$qualifier/go;
}
return $query;
}
sub shorten {
my ( $self, $query, $length ) = @_;
$query =~ s{
\A(
(?:INSERT|REPLACE)
(?:\s+LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)?
(?:\s\w+)*\s+\S+\s+VALUES\s*\(.*?\)
)
\s*,\s*\(.*?(ON\s+DUPLICATE|\Z)}
{$1 /*... omitted ...*/$2}xsi;
return $query unless $query =~ m/IN\s*\(\s*(?!select)/i;
my $last_length = 0;
my $query_length = length($query);
while (
$length > 0
&& $query_length > $length
&& $query_length < ( $last_length || $query_length + 1 )
) {
$last_length = $query_length;
$query =~ s{
(\bIN\s*\() # The opening of an IN list
([^\)]+) # Contents of the list, assuming no item contains paren
(?=\)) # Close of the list
}
{
$1 . __shorten($2)
}gexsi;
}
return $query;
}
sub __shorten {
my ( $snippet ) = @_;
my @vals = split(/,/, $snippet);
return $snippet unless @vals > 20;
my @keep = splice(@vals, 0, 20); # Remove and save the first 20 items
return
join(',', @keep)
. "/*... omitted "
. scalar(@vals)
. " items ...*/";
}
sub fingerprint {
my ( $self, $query ) = @_;
$query =~ m#\ASELECT /\*!40001 SQL_NO_CACHE \*/ \* FROM `# # mysqldump query
&& return 'mysqldump';
$query =~ m#/\*\w+\.\w+:[0-9]/[0-9]\*/# # pt-table-checksum, etc query
&& return 'percona-toolkit';
$query =~ m/\Aadministrator command: /
&& return $query;
$query =~ m/\A\s*(call\s+\S+)\(/i
&& return lc($1); # Warning! $1 used, be careful.
if ( my ($beginning) = $query =~ m/\A((?:INSERT|REPLACE)(?: IGNORE)?\s+INTO.+?VALUES\s*\(.*?\))\s*,\s*\(/is ) {
$query = $beginning; # Shorten multi-value INSERT statements ASAP
}
$query =~ s/$mlc_re//go;
$query =~ s/$olc_re//go;
$query =~ s/\Ause \S+\Z/use ?/i # Abstract the DB in USE
&& return $query;
$query =~ s/\\["']//g; # quoted strings
$query =~ s/".*?"/?/sg; # quoted strings
$query =~ s/'.*?'/?/sg; # quoted strings
$query =~ s/\bfalse\b|\btrue\b/?/isg; # boolean values
if ( $self->{match_md5_checksums} ) {
$query =~ s/([._-])[a-f0-9]{32}/$1?/g;
}
if ( !$self->{match_embedded_numbers} ) {
$query =~ s/[0-9+-][0-9a-f.xb+-]*/?/g;
}
else {
$query =~ s/\b[0-9+-][0-9a-f.xb+-]*/?/g;
}
if ( $self->{match_md5_checksums} ) {
$query =~ s/[xb+-]\?/?/g;
}
else {
$query =~ s/[xb.+-]\?/?/g;
}
$query =~ s/\A\s+//; # Chop off leading whitespace
chomp $query; # Kill trailing whitespace
$query =~ tr[ \n\t\r\f][ ]s; # Collapse whitespace
$query = lc $query;
$query =~ s/\bnull\b/?/g; # Get rid of NULLs
$query =~ s{ # Collapse IN and VALUES lists
\b(in|values?)(?:[\s,]*\([\s?,]*\))+
}
{$1(?+)}gx;
$query =~ s{ # Collapse UNION
\b(select\s.*?)(?:(\sunion(?:\sall)?)\s\1)+
}
{$1 /*repeat$2*/}xg;
$query =~ s/\blimit \?(?:, ?\?| offset \?)?/limit ?/; # LIMIT
if ( $query =~ m/\bORDER BY /gi ) { # Find, anchor on ORDER BY clause
1 while $query =~ s/\G(.+?)\s+ASC/$1/gi && pos $query;
}
return $query;
}
sub distill_verbs {
my ( $self, $query ) = @_;
$query =~ m/\A\s*call\s+(\S+)\(/i && return "CALL $1";
$query =~ m/\A\s*use\s+/ && return "USE";
$query =~ m/\A\s*UNLOCK TABLES/i && return "UNLOCK";
$query =~ m/\A\s*xa\s+(\S+)/i && return "XA_$1";
if ( $query =~ m/\A\s*LOAD/i ) {
my ($tbl) = $query =~ m/INTO TABLE\s+(\S+)/i;
$tbl ||= '';
$tbl =~ s/`//g;
return "LOAD DATA $tbl";
}
if ( $query =~ m/\Aadministrator command:/ ) {
$query =~ s/administrator command:/ADMIN/;
$query = uc $query;
return $query;
}
$query = $self->strip_comments($query);
if ( $query =~ m/\A\s*SHOW\s+/i ) {
PTDEBUG && _d($query);
$query = uc $query;
$query =~ s/\s+(?:SESSION|FULL|STORAGE|ENGINE)\b/ /g;
$query =~ s/\s+COUNT[^)]+\)//g;
$query =~ s/\s+(?:FOR|FROM|LIKE|WHERE|LIMIT|IN)\b.+//ms;
$query =~ s/\A(SHOW(?:\s+\S+){1,2}).*\Z/$1/s;
$query =~ s/\s+/ /g;
PTDEBUG && _d($query);
return $query;
}
eval $QueryParser::data_def_stmts;
eval $QueryParser::tbl_ident;
my ( $dds ) = $query =~ /^\s*($QueryParser::data_def_stmts)\b/i;
if ( $dds) {
$query =~ s/\s+IF(?:\s+NOT)?\s+EXISTS/ /i;
my ( $obj ) = $query =~ m/$dds.+(DATABASE|TABLE)\b/i;
$obj = uc $obj if $obj;
PTDEBUG && _d('Data def statment:', $dds, 'obj:', $obj);
my ($db_or_tbl)
= $query =~ m/(?:TABLE|DATABASE)\s+($QueryParser::tbl_ident)(\s+.*)?/i;
PTDEBUG && _d('Matches db or table:', $db_or_tbl);
return uc($dds . ($obj ? " $obj" : '')), $db_or_tbl;
}
my @verbs = $query =~ m/\b($verbs)\b/gio;
@verbs = do {
my $last = '';
grep { my $pass = $_ ne $last; $last = $_; $pass } map { uc } @verbs;
};
if ( ($verbs[0] || '') eq 'SELECT' && @verbs > 1 ) {
PTDEBUG && _d("False-positive verbs after SELECT:", @verbs[1..$#verbs]);
my $union = grep { $_ eq 'UNION' } @verbs;
@verbs = $union ? qw(SELECT UNION) : qw(SELECT);
}
my $verb_str = join(q{ }, @verbs);
return $verb_str;
}
sub __distill_tables {
my ( $self, $query, $table, %args ) = @_;
my $qp = $args{QueryParser} || $self->{QueryParser};
die "I need a QueryParser argument" unless $qp;
my @tables = map {
$_ =~ s/`//g;
$_ =~ s/(_?)[0-9]+/$1?/g;
$_;
} grep { defined $_ } $qp->get_tables($query);
push @tables, $table if $table;
@tables = do {
my $last = '';
grep { my $pass = $_ ne $last; $last = $_; $pass } @tables;
};
return @tables;
}
sub distill {
my ( $self, $query, %args ) = @_;
if ( $args{generic} ) {
my ($cmd, $arg) = $query =~ m/^(\S+)\s+(\S+)/;
return '' unless $cmd;
$query = (uc $cmd) . ($arg ? " $arg" : '');
}
else {
my ($verbs, $table) = $self->distill_verbs($query, %args);
if ( $verbs && $verbs =~ m/^SHOW/ ) {
my %alias_for = qw(
SCHEMA DATABASE
KEYS INDEX
INDEXES INDEX
);
map { $verbs =~ s/$_/$alias_for{$_}/ } keys %alias_for;
$query = $verbs;
}
elsif ( $verbs && $verbs =~ m/^LOAD DATA/ ) {
return $verbs;
}
else {
my @tables = $self->__distill_tables($query, $table, %args);
$query = join(q{ }, $verbs, @tables);
}
}
if ( $args{trf} ) {
$query = $args{trf}->($query, %args);
}
return $query;
}
sub convert_to_select {
my ( $self, $query ) = @_;
return unless $query;
return if $query =~ m/=\s*\(\s*SELECT /i;
$query =~ s{
\A.*?
update(?:\s+(?:low_priority|ignore))?\s+(.*?)
\s+set\b(.*?)
(?:\s*where\b(.*?))?
(limit\s*[0-9]+(?:\s*,\s*[0-9]+)?)?
\Z
}
{__update_to_select($1, $2, $3, $4)}exsi
|| $query =~ s{
\A.*?
(?:insert(?:\s+ignore)?|replace)\s+
.*?\binto\b(.*?)\(([^\)]+)\)\s*
values?\s*(\(.*?\))\s*
(?:\blimit\b|on\s+duplicate\s+key.*)?\s*
\Z
}
{__insert_to_select($1, $2, $3)}exsi
|| $query =~ s{
\A.*?
(?:insert(?:\s+ignore)?|replace)\s+
(?:.*?\binto)\b(.*?)\s*
set\s+(.*?)\s*
(?:\blimit\b|on\s+duplicate\s+key.*)?\s*
\Z
}
{__insert_to_select_with_set($1, $2)}exsi
|| $query =~ s{
\A.*?
delete\s+(.*?)
\bfrom\b(.*)
\Z
}
{__delete_to_select($1, $2)}exsi;
$query =~ s/\s*on\s+duplicate\s+key\s+update.*\Z//si;
$query =~ s/\A.*?(?=\bSELECT\s*\b)//ism;
return $query;
}
sub convert_select_list {
my ( $self, $query ) = @_;
$query =~ s{
\A\s*select(.*?)\bfrom\b
}
{$1 =~ m/\*/ ? "select 1 from" : "select isnull(coalesce($1)) from"}exi;
return $query;
}
sub __delete_to_select {
my ( $delete, $join ) = @_;
if ( $join =~ m/\bjoin\b/ ) {
return "select 1 from $join";
}
return "select * from $join";
}
sub __insert_to_select {
my ( $tbl, $cols, $vals ) = @_;
PTDEBUG && _d('Args:', @_);
my @cols = split(/,/, $cols);
PTDEBUG && _d('Cols:', @cols);
$vals =~ s/^\(|\)$//g; # Strip leading/trailing parens
my @vals = $vals =~ m/($quote_re|[^,]*${bal}[^,]*|[^,]+)/g;
PTDEBUG && _d('Vals:', @vals);
if ( @cols == @vals ) {
return "select * from $tbl where "
. join(' and ', map { "$cols[$_]=$vals[$_]" } (0..$#cols));
}
else {
return "select * from $tbl limit 1";
}
}
sub __insert_to_select_with_set {
my ( $from, $set ) = @_;
$set =~ s/,/ and /g;
return "select * from $from where $set ";
}
sub __update_to_select {
my ( $from, $set, $where, $limit ) = @_;
return "select $set from $from "
. ( $where ? "where $where" : '' )
. ( $limit ? " $limit " : '' );
}
sub wrap_in_derived {
my ( $self, $query ) = @_;
return unless $query;
return $query =~ m/\A\s*select/i
? "select 1 from ($query) as x limit 1"
: $query;
}
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 QueryRewriter package
# ###########################################################################
# ###########################################################################
# SlowLogParser 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/SlowLogParser.pm
# t/lib/SlowLogParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package SlowLogParser;
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 ) = @_;
my $self = {
pending => [],
last_event_offset => undef,
};
return bless $self, $class;
}
my $slow_log_ts_line = qr/^# Time: ((?:[0-9: ]{15})|(?:[-0-9: T]{19}))/;
my $slow_log_uh_line = qr/# User\@Host: ([^\[]+|\[[^[]+\]).*?@ (\S*) \[(.*)\]\s*(?:Id:\s*(\d+))?/;
my $slow_log_hd_line = qr{
^(?:
T[cC][pP]\s[pP]ort:\s+\d+ # case differs on windows/unix
|
[/A-Z].*mysqld,\sVersion.*(?:started\swith:|embedded\slibrary)
|
Time\s+Id\s+Command
).*\n
}xm;
sub parse_event {
my ( $self, %args ) = @_;
my @required_args = qw(next_event tell);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($next_event, $tell) = @args{@required_args};
my $pending = $self->{pending};
local $INPUT_RECORD_SEPARATOR = ";\n#";
my $trimlen = length($INPUT_RECORD_SEPARATOR);
my $pos_in_log = $tell->();
my $stmt;
EVENT:
while (
defined($stmt = shift @$pending)
or defined($stmt = $next_event->())
) {
my @properties = ('cmd', 'Query', 'pos_in_log', $pos_in_log);
$self->{last_event_offset} = $pos_in_log;
$pos_in_log = $tell->();
if ( $stmt =~ s/$slow_log_hd_line//go ){ # Throw away header lines in log
my @chunks = split(/$INPUT_RECORD_SEPARATOR/o, $stmt);
if ( @chunks > 1 ) {
PTDEBUG && _d("Found multiple chunks");
$stmt = shift @chunks;
unshift @$pending, @chunks;
}
}
$stmt = '#' . $stmt unless $stmt =~ m/\A#/;
$stmt =~ s/;\n#?\Z//;
my ($got_ts, $got_uh, $got_ac, $got_db, $got_set, $got_embed);
my $pos = 0;
my $len = length($stmt);
my $found_arg = 0;
LINE:
while ( $stmt =~ m/^(.*)$/mg ) { # /g is important, requires scalar match.
$pos = pos($stmt); # Be careful not to mess this up!
my $line = $1; # Necessary for /g and pos() to work.
PTDEBUG && _d($line);
if ($line =~ m/^(?:#|use |SET (?:last_insert_id|insert_id|timestamp))/o) {
if ( !$got_ts && (my ( $time ) = $line =~ m/$slow_log_ts_line/o)) {
PTDEBUG && _d("Got ts", $time);
push @properties, 'ts', $time;
++$got_ts;
if ( !$got_uh
&& ( my ( $user, $host, $ip, $thread_id ) = $line =~ m/$slow_log_uh_line/o )
) {
PTDEBUG && _d("Got user, host, ip", $user, $host, $ip);
$host ||= $ip; # sometimes host is missing when using skip-name-resolve (LP #issue 1262456)
push @properties, 'user', $user, 'host', $host, 'ip', $ip;
if ( $thread_id ) {
push @properties, 'Thread_id', $thread_id;
}
++$got_uh;
}
}
elsif ( !$got_uh
&& ( my ( $user, $host, $ip, $thread_id ) = $line =~ m/$slow_log_uh_line/o )
) {
PTDEBUG && _d("Got user, host, ip", $user, $host, $ip);
$host ||= $ip; # sometimes host is missing when using skip-name-resolve (LP #issue 1262456)
push @properties, 'user', $user, 'host', $host, 'ip', $ip;
if ( $thread_id ) {
push @properties, 'Thread_id', $thread_id;
}
++$got_uh;
}
elsif (!$got_ac && $line =~ m/^# (?:administrator command:.*)$/) {
PTDEBUG && _d("Got admin command");
$line =~ s/^#\s+//; # string leading "# ".
push @properties, 'cmd', 'Admin', 'arg', $line;
push @properties, 'bytes', length($properties[-1]);
++$found_arg;
++$got_ac;
}
elsif ( $line =~ m/^# +[A-Z][A-Za-z_]+: \S+/ ) { # Make the test cheap!
PTDEBUG && _d("Got some line with properties");
if ( $line =~ m/Schema:\s+\w+: / ) {
PTDEBUG && _d('Removing empty Schema attrib');
$line =~ s/Schema:\s+//;
PTDEBUG && _d($line);
}
my @temp = $line =~ m/(\w+):\s+(\S+|\Z)/g;
push @properties, @temp;
}
elsif ( !$got_db && (my ( $db ) = $line =~ m/^use ([^;]+)/ ) ) {
PTDEBUG && _d("Got a default database:", $db);
push @properties, 'db', $db;
++$got_db;
}
elsif (!$got_set && (my ($setting) = $line =~ m/^SET\s+([^;]*)/)) {
PTDEBUG && _d("Got some setting:", $setting);
push @properties, split(/,|\s*=\s*/, $setting);
++$got_set;
}
if ( !$found_arg && $pos == $len ) {
PTDEBUG && _d("Did not find arg, looking for special cases");
local $INPUT_RECORD_SEPARATOR = ";\n"; # get next line
if ( defined(my $l = $next_event->()) ) {
if ( $l =~ /^\s*[A-Z][a-z_]+: / ) {
PTDEBUG && _d("Found NULL query before", $l);
local $INPUT_RECORD_SEPARATOR = ";\n#";
my $rest_of_event = $next_event->();
push @{$self->{pending}}, $l . $rest_of_event;
push @properties, 'cmd', 'Query', 'arg', '/* No query */';
push @properties, 'bytes', 0;
$found_arg++;
}
else {
chomp $l;
$l =~ s/^\s+//;
PTDEBUG && _d("Found admin statement", $l);
push @properties, 'cmd', 'Admin', 'arg', $l;
push @properties, 'bytes', length($properties[-1]);
$found_arg++;
}
}
else {
PTDEBUG && _d("I can't figure out what to do with this line");
next EVENT;
}
}
}
else {
PTDEBUG && _d("Got the query/arg line");
my $arg = substr($stmt, $pos - length($line));
push @properties, 'arg', $arg, 'bytes', length($arg);
if ( $args{misc} && $args{misc}->{embed}
&& ( my ($e) = $arg =~ m/($args{misc}->{embed})/)
) {
push @properties, $e =~ m/$args{misc}->{capture}/g;
}
last LINE;
}
}
PTDEBUG && _d('Properties of event:', Dumper(\@properties));
my $event = { @properties };
if ( !$event->{arg} ) {
PTDEBUG && _d('Partial event, no arg');
}
else {
$self->{last_event_offset} = undef;
if ( $args{stats} ) {
$args{stats}->{events_read}++;
$args{stats}->{events_parsed}++;
}
}
return $event;
} # EVENT
@$pending = ();
$args{oktorun}->(0) if $args{oktorun};
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 SlowLogParser 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;
local $EVAL_ERROR;
eval {
require Quoter;
};
sub new {
my ( $class, %args ) = @_;
my $self = { %args };
$self->{Quoter} ||= Quoter->new();
return bless $self, $class;
}
sub Quoter { shift->{Quoter} }
sub get_create_table {
my ( $self, $dbh, $db, $tbl ) = @_;
die "I need a dbh parameter" unless $dbh;
die "I need a db parameter" unless $db;
die "I need a tbl parameter" unless $tbl;
my $q = $self->{Quoter};
my $new_sql_mode
= q{/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, }
. q{@@SQL_MODE := '', }
. q{@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, }
. q{@@SQL_QUOTE_SHOW_CREATE := 1 */};
my $old_sql_mode
= q{/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, }
. q{@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */};
PTDEBUG && _d($new_sql_mode);
eval { $dbh->do($new_sql_mode); };
PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
my $use_sql = 'USE ' . $q->quote($db);
PTDEBUG && _d($dbh, $use_sql);
$dbh->do($use_sql);
my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
PTDEBUG && _d($show_sql);
my $href;
eval { $href = $dbh->selectrow_hashref($show_sql); };
if ( my $e = $EVAL_ERROR ) {
PTDEBUG && _d($old_sql_mode);
$dbh->do($old_sql_mode);
die $e;
}
PTDEBUG && _d($old_sql_mode);
$dbh->do($old_sql_mode);
my ($key) = grep { m/create (?:table|view)/i } keys %$href;
if ( !$key ) {
die "Error: no 'Create Table' or 'Create View' in result set from "
. "$show_sql: " . Dumper($href);
}
return $href->{$key};
}
sub parse {
my ( $self, $ddl, $opts ) = @_;
return unless $ddl;
if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) {
$ddl = $self->ansi_to_legacy($ddl);
}
elsif ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
die "TableParser doesn't handle CREATE TABLE without quoting.";
}
my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
(undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
$ddl =~ s/(`[^`\n]+`)/\L$1/gm;
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, @non_generated);
my (%type_for, %is_nullable, %is_numeric, %is_autoinc, %is_generated);
foreach my $col ( @cols ) {
my $def = $def_for{$col};
$def =~ s/``//g;
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;
}
if ( remove_quoted_text($def) =~ m/\WGENERATED\W/i ) {
$is_generated{$col} = 1;
} else {
push @non_generated, $col;
}
$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 } @non_generated },
null_cols => \@null,
is_nullable => \%is_nullable,
non_generated_cols => \@non_generated,
is_autoinc => \%is_autoinc,
is_generated => \%is_generated,
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 remove_quoted_text {
my ($string) = @_;
$string =~ s/[^\\]`[^`]*[^\\]`//g;
$string =~ s/[^\\]"[^"]*[^\\]"//g;
$string =~ s/[^\\]'[^']*[^\\]'//g;
return $string;
}
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} || 'Quoter';
my $db_tbl = $q->quote($db, $tbl);
PTDEBUG && _d('Checking', $db_tbl);
$self->{check_table_error} = undef;
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 ( my $e = $EVAL_ERROR ) {
PTDEBUG && _d($e);
$self->{check_table_error} = $e;
return 0;
}
if ( !$row->[0] || $row->[0] ne $tbl ) {
PTDEBUG && _d('Table does not exist');
return 0;
}
PTDEBUG && _d('Table', $db, $tbl, 'exists');
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 || $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';
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 get_table_status {
my ( $self, $dbh, $db, $like ) = @_;
my $q = $self->{Quoter};
my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
my @params;
if ( $like ) {
$sql .= ' LIKE ?';
push @params, $like;
}
PTDEBUG && _d($sql, @params);
my $sth = $dbh->prepare($sql);
eval { $sth->execute(@params); };
if ($EVAL_ERROR) {
PTDEBUG && _d($EVAL_ERROR);
return;
}
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;
return @tables;
}
my $ansi_quote_re = qr/" [^"]* (?: "" [^"]* )* (?<=.) "/ismx;
sub ansi_to_legacy {
my ($self, $ddl) = @_;
$ddl =~ s/($ansi_quote_re)/ansi_quote_replace($1)/ge;
return $ddl;
}
sub ansi_quote_replace {
my ($val) = @_;
$val =~ s/^"|"$//g;
$val =~ s/`/``/g;
$val =~ s/""/"/g;
return "`$val`";
}
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
# ###########################################################################
# ###########################################################################
# Transformers package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Transformers.pm
# t/lib/Transformers.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Transformers;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Time::Local qw(timegm timelocal);
use Digest::MD5 qw(md5_hex);
use B qw();
BEGIN {
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ();
our @EXPORT = ();
our @EXPORT_OK = qw(
micro_t
percentage_of
secs_to_time
time_to_secs
shorten
ts
parse_timestamp
unix_timestamp
any_unix_timestamp
make_checksum
crc32
encode_json
);
}
our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
sub micro_t {
my ( $t, %args ) = @_;
my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
my $f;
$t = 0 if $t < 0;
$t = sprintf('%.17f', $t) if $t =~ /e/;
$t =~ s/\.(\d{1,6})\d*/\.$1/;
if ($t > 0 && $t <= 0.000999) {
$f = ($t * 1000000) . 'us';
}
elsif ($t >= 0.001000 && $t <= 0.999999) {
$f = sprintf("%.${p_ms}f", $t * 1000);
$f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
}
elsif ($t >= 1) {
$f = sprintf("%.${p_s}f", $t);
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
}
else {
$f = 0; # $t should = 0 at this point
}
return $f;
}
sub percentage_of {
my ( $is, $of, %args ) = @_;
my $p = $args{p} || 0; # float precision
my $fmt = $p ? "%.${p}f" : "%d";
return sprintf $fmt, ($is * 100) / ($of ||= 1);
}
sub secs_to_time {
my ( $secs, $fmt ) = @_;
$secs ||= 0;
return '00:00' unless $secs;
$fmt ||= $secs >= 86_400 ? 'd'
: $secs >= 3_600 ? 'h'
: 'm';
return
$fmt eq 'd' ? sprintf(
"%d+%02d:%02d:%02d",
int($secs / 86_400),
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: $fmt eq 'h' ? sprintf(
"%02d:%02d:%02d",
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: sprintf(
"%02d:%02d",
int(($secs % 3_600) / 60),
$secs % 60);
}
sub time_to_secs {
my ( $val, $default_suffix ) = @_;
die "I need a val argument" unless defined $val;
my $t = 0;
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
$suffix = $suffix || $default_suffix || 's';
if ( $suffix =~ m/[smhd]/ ) {
$t = $suffix eq 's' ? $num * 1 # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$t *= -1 if $prefix && $prefix eq '-';
}
else {
die "Invalid suffix for $val: $suffix";
}
return $t;
}
sub shorten {
my ( $num, %args ) = @_;
my $p = defined $args{p} ? $args{p} : 2; # float precision
my $d = defined $args{d} ? $args{d} : 1_024; # divisor
my $n = 0;
my @units = ('', qw(k M G T P E Z Y));
while ( $num >= $d && $n < @units - 1 ) {
$num /= $d;
++$n;
}
return sprintf(
$num =~ m/\./ || $n
? '%1$.'.$p.'f%2$s'
: '%1$d',
$num, $units[$n]);
}
sub ts {
my ( $time, $gmt ) = @_;
my ( $sec, $min, $hour, $mday, $mon, $year )
= $gmt ? gmtime($time) : localtime($time);
$mon += 1;
$year += 1900;
my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
$us = sprintf("%.6f", $us);
$us =~ s/^0\././;
$val .= $us;
}
return $val;
}
sub parse_timestamp {
my ( $val ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $f)
= $val =~ m/^$mysql_ts$/ )
{
return sprintf "%d-%02d-%02d %02d:%02d:"
. (defined $f ? '%09.6f' : '%02d'),
$y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
}
elsif ( $val =~ m/^$proper_ts$/ ) {
return $val;
}
return $val;
}
sub unix_timestamp {
my ( $val, $gmt ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
$val = $gmt
? timegm($s, $i, $h, $d, $m - 1, $y)
: timelocal($s, $i, $h, $d, $m - 1, $y);
if ( defined $us ) {
$us = sprintf('%.6f', $us);
$us =~ s/^0\././;
$val .= $us;
}
}
return $val;
}
sub any_unix_timestamp {
my ( $val, $callback ) = @_;
if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
$n = $suffix eq 's' ? $n # Seconds
: $suffix eq 'm' ? $n * 60 # Minutes
: $suffix eq 'h' ? $n * 3600 # Hours
: $suffix eq 'd' ? $n * 86400 # Days
: $n; # default: Seconds
PTDEBUG && _d('ts is now - N[shmd]:', $n);
return time - $n;
}
elsif ( $val =~ m/^\d{9,}/ ) {
PTDEBUG && _d('ts is already a unix timestamp');
return $val;
}
elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
PTDEBUG && _d('ts is MySQL slow log timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp(parse_timestamp($val));
}
elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
PTDEBUG && _d('ts is properly formatted timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp($val);
}
else {
PTDEBUG && _d('ts is MySQL expression');
return $callback->($val) if $callback && ref $callback eq 'CODE';
}
PTDEBUG && _d('Unknown ts type:', $val);
return;
}
sub make_checksum {
my ( $val ) = @_;
my $checksum = uc substr(md5_hex($val), -16);
PTDEBUG && _d($checksum, 'checksum for', $val);
return $checksum;
}
sub crc32 {
my ( $string ) = @_;
return unless $string;
my $poly = 0xEDB88320;
my $crc = 0xFFFFFFFF;
foreach my $char ( split(//, $string) ) {
my $comp = ($crc ^ ord($char)) & 0xFF;
for ( 1 .. 8 ) {
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
}
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
}
return $crc ^ 0xFFFFFFFF;
}
my $got_json = eval { require JSON };
sub encode_json {
return JSON::encode_json(@_) if $got_json;
my ( $data ) = @_;
return (object_to_json($data) || '');
}
sub object_to_json {
my ($obj) = @_;
my $type = ref($obj);
if($type eq 'HASH'){
return hash_to_json($obj);
}
elsif($type eq 'ARRAY'){
return array_to_json($obj);
}
else {
return value_to_json($obj);
}
}
sub hash_to_json {
my ($obj) = @_;
my @res;
for my $k ( sort { $a cmp $b } keys %$obj ) {
push @res, string_to_json( $k )
. ":"
. ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) );
}
return '{' . ( @res ? join( ",", @res ) : '' ) . '}';
}
sub array_to_json {
my ($obj) = @_;
my @res;
for my $v (@$obj) {
push @res, object_to_json($v) || value_to_json($v);
}
return '[' . ( @res ? join( ",", @res ) : '' ) . ']';
}
sub value_to_json {
my ($value) = @_;
return 'null' if(!defined $value);
my $b_obj = B::svref_2object(\$value); # for round trip problem
my $flags = $b_obj->FLAGS;
return $value # as is
if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
my $type = ref($value);
if( !$type ) {
return string_to_json($value);
}
else {
return 'null';
}
}
my %esc = (
"\n" => '\n',
"\r" => '\r',
"\t" => '\t',
"\f" => '\f',
"\b" => '\b',
"\"" => '\"',
"\\" => '\\\\',
"\'" => '\\\'',
);
sub string_to_json {
my ($arg) = @_;
$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
$arg =~ s/\//\\\//g;
$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
utf8::upgrade($arg);
utf8::encode($arg);
return '"' . $arg . '"';
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Transformers package
# ###########################################################################
# ###########################################################################
# 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 TableParser 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 %resume;
if ( my $table = $args{resume} ) {
PTDEBUG && _d('Will resume from or after', $table);
my ($db, $tbl) = $args{Quoter}->split_unquote($table);
die "Resume table must be database-qualified: $table"
unless $db && $tbl;
$resume{db} = $db;
$resume{tbl} = $tbl;
}
my $self = {
%args,
resume => \%resume,
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}->{$db}->{$tbl} = 1;
}
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 {
my ( $self ) = @_;
if ( !$self->{initialized} ) {
$self->{initialized} = 1;
if ( $self->{resume}->{tbl} ) {
if ( !$self->table_is_allowed(@{$self->{resume}}{qw(db tbl)}) ) {
PTDEBUG && _d('Will resume after',
join('.', @{$self->{resume}}{qw(db tbl)}));
$self->{resume}->{after}->{tbl} = 1;
}
if ( !$self->database_is_allowed($self->{resume}->{db}) ) {
PTDEBUG && _d('Will resume after', $self->{resume}->{db});
$self->{resume}->{after}->{db} = 1;
}
}
}
my $schema_obj;
if ( $self->{file_itr} ) {
$schema_obj= $self->_iterate_files();
}
else { # dbh
$schema_obj= $self->_iterate_dbh();
}
if ( $schema_obj ) {
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->_resume_from_database($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->_resume_from_table($tbl)
&& $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 $tbl_struct = $self->{TableParser}->parse($ddl);
if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
return {
db => $self->{db},
tbl => $tbl,
name => $self->{Quoter}->quote($self->{db}, $tbl),
ddl => $ddl,
tbl_struct => $tbl_struct,
};
}
}
}
} # 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 $tp = $self->{TableParser};
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->_resume_from_database($_)
&&
$self->database_is_allowed($_)
} @{$dbh->selectcol_arrayref($sql)};
PTDEBUG && _d('Found', scalar @dbs, 'databases');
$self->{dbs} = \@dbs;
}
DATABASE:
while ( $self->{db} || defined(my $db = shift @{$self->{dbs}}) ) {
if ( !$self->{db} ) {
PTDEBUG && _d('Next database:', $db);
$self->{db} = $db;
}
if ( !$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) = @$_;
(!$type || ($type ne 'VIEW'))
&& $self->_resume_from_table($tbl)
&& $self->table_is_allowed($self->{db}, $tbl);
}
eval { @{$dbh->selectall_arrayref($sql)}; };
if ($EVAL_ERROR) {
warn "Skipping $self->{db}...";
$self->{db} = undef;
next;
}
PTDEBUG && _d('Found', scalar @tbls, 'tables in database',$self->{db});
$self->{tbls} = \@tbls;
}
TABLE:
while ( my $tbl = shift @{$self->{tbls}} ) {
my $ddl = eval { $tp->get_create_table($dbh, $self->{db}, $tbl) };
if ( my $e = $EVAL_ERROR ) {
my $table_name = "$self->{db}.$tbl";
if ( $e =~ /\QTable '$table_name' doesn't exist/ ) {
PTDEBUG && _d("$table_name no longer exists");
}
else {
warn "Skipping $table_name because SHOW CREATE TABLE failed: $e";
}
next TABLE;
}
my $tbl_struct = $tp->parse($ddl);
if ( $self->engine_is_allowed($tbl_struct->{engine}) ) {
return {
db => $self->{db},
tbl => $tbl,
name => $q->quote($self->{db}, $tbl),
ddl => $ddl,
tbl_struct => $tbl_struct,
};
}
}
PTDEBUG && _d('No more tables in database', $self->{db});
$self->{db} = undef;
$self->{tbls} = undef;
} # DATABASE
PTDEBUG && _d('No more databases');
return;
}
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|percona_schema)$/ ) {
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};
return 0 if $db eq 'mysql' && $tbl =~ m/^(?:
general_log
|gtid_executed
|innodb_index_stats
|innodb_table_stats
|slave_master_info
|slave_relay_log_info
|slave_worker_info
|slow_log
)$/x;
if ( $filter->{'ignore-tables'}->{'*'}->{$tbl}
|| $filter->{'ignore-tables'}->{$db}->{$tbl}) {
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} && !$filter->{'tables'}->{$db}->{$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 ) = @_;
if ( !$engine ) {
PTDEBUG && _d('No engine specified; allowing the table');
return 1;
}
$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 _resume_from_database {
my ($self, $db) = @_;
return 1 unless $self->{resume}->{db};
if ( $db eq $self->{resume}->{db} ) {
if ( !$self->{resume}->{after}->{db} ) {
PTDEBUG && _d('Resuming from db', $db);
delete $self->{resume}->{db};
return 1;
}
else {
PTDEBUG && _d('Resuming after db', $db);
delete $self->{resume}->{db};
delete $self->{resume}->{tbl};
}
}
return 0;
}
sub _resume_from_table {
my ($self, $tbl) = @_;
return 1 unless $self->{resume}->{tbl};
if ( $tbl eq $self->{resume}->{tbl} ) {
if ( !$self->{resume}->{after}->{tbl} ) {
PTDEBUG && _d('Resuming from table', $tbl);
delete $self->{resume}->{tbl};
return 1;
}
else {
PTDEBUG && _d('Resuming after table', $tbl);
delete $self->{resume}->{tbl};
}
}
return 0;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End SchemaIterator package
# ###########################################################################
# ###########################################################################
# FileIterator 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/FileIterator.pm
# t/lib/FileIterator.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package FileIterator;
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_file_itr {
my ( $self, @filenames ) = @_;
my @final_filenames;
FILENAME:
foreach my $fn ( @filenames ) {
if ( !defined $fn ) {
warn "Skipping undefined filename";
next FILENAME;
}
if ( $fn ne '-' ) {
if ( !-e $fn || !-r $fn ) {
warn "$fn does not exist or is not readable";
next FILENAME;
}
}
push @final_filenames, $fn;
}
if ( !@filenames ) {
push @final_filenames, '-';
PTDEBUG && _d('Auto-adding "-" to the list of filenames');
}
PTDEBUG && _d('Final filenames:', @final_filenames);
return sub {
while ( @final_filenames ) {
my $fn = shift @final_filenames;
PTDEBUG && _d('Filename:', $fn);
if ( $fn eq '-' ) { # Magical STDIN filename.
return (*STDIN, undef, undef);
}
open my $fh, '<', $fn or warn "Cannot open $fn: $OS_ERROR";
if ( $fh ) {
return ( $fh, $fn, -s $fn );
}
}
return (); # Avoids $f being set to 0 in list context.
};
}
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 FileIterator package
# ###########################################################################
# ###########################################################################
# ExplainAnalyzer 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/ExplainAnalyzer.pm
# t/lib/ExplainAnalyzer.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package ExplainAnalyzer;
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 ) = @_;
foreach my $arg ( qw(QueryRewriter QueryParser) ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my $self = {
%args,
};
return bless $self, $class;
}
sub explain_query {
my ( $self, %args ) = @_;
foreach my $arg ( qw(dbh query) ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($query, $dbh) = @args{qw(query dbh)};
$query = $self->{QueryRewriter}->convert_to_select($query);
if ( $query !~ m/^\s*select/i ) {
PTDEBUG && _d("Cannot EXPLAIN non-SELECT query:",
(length $query <= 100 ? $query : substr($query, 0, 100) . "..."));
return;
}
my $sql = "EXPLAIN $query";
PTDEBUG && _d($dbh, $sql);
my $explain = $dbh->selectall_arrayref($sql, { Slice => {} });
PTDEBUG && _d("Result of EXPLAIN:", Dumper($explain));
return $explain;
}
sub normalize {
my ( $self, $explain ) = @_;
my @result; # Don't modify the input.
foreach my $row ( @$explain ) {
$row = { %$row }; # Make a copy -- don't modify the input.
foreach my $col ( qw(key possible_keys key_len ref) ) {
$row->{$col} = [ split(/,/, $row->{$col} || '') ];
}
$row->{Extra} = {
map {
my $var = $_;
if ( my ($key, $vals) = $var =~ m/(Using union)\(([^)]+)\)/ ) {
$key => [ split(/,/, $vals) ];
}
else {
$var => 1;
}
}
split(/; /, $row->{Extra} || '') # Split on semicolons.
};
push @result, $row;
}
return \@result;
}
sub get_alternate_indexes {
my ( $self, $keys, $possible_keys ) = @_;
my %used = map { $_ => 1 } @$keys;
return [ grep { !$used{$_} } @$possible_keys ];
}
sub get_index_usage {
my ( $self, %args ) = @_;
foreach my $arg ( qw(query explain) ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($query, $explain) = @args{qw(query explain)};
my @result;
my $lookup = $self->{QueryParser}->get_aliases($query);
foreach my $row ( @$explain ) {
next if !defined $row->{table}
|| $row->{table} =~ m/^<(derived|union)\d/;
my $table = $lookup->{TABLE}->{$row->{table}} || $row->{table};
my $db = $lookup->{DATABASE}->{$table} || $args{db};
push @result, {
db => $db,
tbl => $table,
idx => $row->{key},
alt => $self->get_alternate_indexes(
$row->{key}, $row->{possible_keys}),
};
}
PTDEBUG && _d("Index usage for",
(length $query <= 100 ? $query : substr($query, 0, 100) . "..."),
":", Dumper(\@result));
return \@result;
}
sub get_usage_for {
my ( $self, $checksum, $db ) = @_;
die "I need a checksum and db" unless defined $checksum && defined $db;
my $usage;
if ( exists $self->{usage}->{$db} # Don't auto-vivify
&& exists $self->{usage}->{$db}->{$checksum} )
{
$usage = $self->{usage}->{$db}->{$checksum};
}
PTDEBUG && _d("Usage for",
(length $checksum <= 100 ? $checksum : substr($checksum, 0, 100) . "..."),
"on", $db, ":", Dumper($usage));
return $usage;
}
sub save_usage_for {
my ( $self, $checksum, $db, $usage ) = @_;
die "I need a checksum and db" unless defined $checksum && defined $db;
$self->{usage}->{$db}->{$checksum} = $usage;
}
sub fingerprint {
my ( $self, %args ) = @_;
my @required_args = qw(explain);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($explain) = @args{@required_args};
}
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 ExplainAnalyzer package
# ###########################################################################
# ###########################################################################
# IndexUsage 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/IndexUsage.pm
# t/lib/IndexUsage.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package IndexUsage;
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,
tables_for => {}, # Keyed off db
indexes_for => {}, # Keyed off db->tbl
queries => {}, # Keyed off query id
index_usage => {}, # Keyed off query id->db->tbl
alt_index_usage => {}, # Keyed off query id->db->tbl->index
};
return bless $self, $class;
}
sub add_indexes {
my ( $self, %args ) = @_;
my @required_args = qw(db tbl indexes);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($db, $tbl, $indexes) = @args{@required_args};
$self->{tables_for}->{$db}->{$tbl} = 0; # usage cnt, zero until used
$self->{indexes_for}->{$db}->{$tbl} = $indexes;
foreach my $index ( keys %$indexes ) {
$indexes->{$index}->{cnt} = 0;
}
return;
}
sub add_query {
my ( $self, %args ) = @_;
my @required_args = qw(query_id fingerprint sample);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($query_id, $fingerprint, $sample) = @args{@required_args};
$self->{queries}->{$query_id} = {
fingerprint => $fingerprint,
sample => $sample,
};
return;
}
sub add_table_usage {
my ( $self, $db, $tbl ) = @_;
die "I need a db and table" unless defined $db && defined $tbl;
++$self->{tables_for}->{$db}->{$tbl};
return;
}
sub add_index_usage {
my ( $self, %args ) = @_;
my @required_args = qw(usage);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($usage) = @args{@required_args};
foreach my $access ( @$usage ) {
my ($db, $tbl, $idx, $alt) = @{$access}{qw(db tbl idx alt)};
foreach my $index ( @$idx ) {
$self->{indexes_for}->{$db}->{$tbl}->{$index}->{cnt}++;
if ( my $query_id = $args{query_id} ) {
$self->{index_usage}->{$query_id}->{$db}->{$tbl}->{$index}++;
foreach my $alt_index ( @$alt ) {
$self->{alt_index_usage}->{$query_id}->{$db}->{$tbl}->{$index}->{$alt_index}++;
}
}
} # INDEX
} # ACCESS
return;
}
sub find_unused_indexes {
my ( $self, $callback ) = @_;
die "I need a callback" unless $callback;
PTDEBUG && _d("Finding unused indexes");
DATABASE:
foreach my $db ( sort keys %{$self->{indexes_for}} ) {
TABLE:
foreach my $tbl ( sort keys %{$self->{indexes_for}->{$db}} ) {
next TABLE unless $self->{tables_for}->{$db}->{$tbl}; # Skip unused
my $indexes = $self->{indexes_for}->{$db}->{$tbl};
my @unused_indexes;
foreach my $index ( sort keys %$indexes ) {
if ( !$indexes->{$index}->{cnt} ) { # count of times accessed/used
push @unused_indexes, $indexes->{$index};
}
}
if ( @unused_indexes ) {
$callback->(
{ db => $db,
tbl => $tbl,
idx => \@unused_indexes,
}
);
}
} # TABLE
} # DATABASE
return;
}
sub save_results {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($dbh, $db) = @args{@required_args};
PTDEBUG && _d("Saving results to tables in database", $db);
PTDEBUG && _d("Saving index data");
my $insert_index_sth = $dbh->prepare(
"INSERT INTO `$db`.`indexes` (db, tbl, idx, cnt) VALUES (?, ?, ?, ?) "
. "ON DUPLICATE KEY UPDATE cnt = cnt + ?");
foreach my $db ( keys %{$self->{indexes_for}} ) {
foreach my $tbl ( keys %{$self->{indexes_for}->{$db}} ) {
foreach my $index ( keys %{$self->{indexes_for}->{$db}->{$tbl}} ) {
my $cnt = $self->{indexes_for}->{$db}->{$tbl}->{$index}->{cnt};
$insert_index_sth->execute($db, $tbl, $index, $cnt, $cnt);
}
}
}
PTDEBUG && _d("Saving table data");
my $insert_tbl_sth = $dbh->prepare(
"INSERT INTO `$db`.`tables` (db, tbl, cnt) VALUES (?, ?, ?) "
. "ON DUPLICATE KEY UPDATE cnt = cnt + ?");
foreach my $db ( keys %{$self->{tables_for}} ) {
foreach my $tbl ( keys %{$self->{tables_for}->{$db}} ) {
my $cnt = $self->{tables_for}->{$db}->{$tbl};
$insert_tbl_sth->execute($db, $tbl, $cnt, $cnt);
}
}
PTDEBUG && _d("Save query data");
my $insert_query_sth = $dbh->prepare(
"INSERT IGNORE INTO `$db`.`queries` (query_id, fingerprint, sample) "
. " VALUES (CONV(?, 16, 10), ?, ?)");
foreach my $query_id ( keys %{$self->{queries}} ) {
my $query = $self->{queries}->{$query_id};
$insert_query_sth->execute(
$query_id, $query->{fingerprint}, $query->{sample});
}
PTDEBUG && _d("Saving index usage data");
my $insert_index_usage_sth = $dbh->prepare(
"INSERT INTO `$db`.`index_usage` (query_id, db, tbl, idx, cnt) "
. "VALUES (CONV(?, 16, 10), ?, ?, ?, ?) "
. "ON DUPLICATE KEY UPDATE cnt = cnt + ?");
foreach my $query_id ( keys %{$self->{index_usage}} ) {
foreach my $db ( keys %{$self->{index_usage}->{$query_id}} ) {
foreach my $tbl ( keys %{$self->{index_usage}->{$query_id}->{$db}} ) {
my $indexes = $self->{index_usage}->{$query_id}->{$db}->{$tbl};
foreach my $index ( keys %$indexes ) {
my $cnt = $indexes->{$index};
$insert_index_usage_sth->execute(
$query_id, $db, $tbl, $index, $cnt, $cnt);
}
}
}
}
PTDEBUG && _d("Saving alternate index usage data");
my $insert_index_alt_sth = $dbh->prepare(
"INSERT INTO `$db`.`index_alternatives` "
. "(query_id, db, tbl, idx, alt_idx, cnt) "
. "VALUES (CONV(?, 16, 10), ?, ?, ?, ?, ?) "
. "ON DUPLICATE KEY UPDATE cnt = cnt + ?");
foreach my $query_id ( keys %{$self->{alt_index_usage}} ) {
foreach my $db ( keys %{$self->{alt_index_usage}->{$query_id}} ) {
foreach my $tbl ( keys %{$self->{alt_index_usage}->{$query_id}->{$db}} ) {
foreach my $index ( keys %{$self->{alt_index_usage}->{$query_id}->{$db}->{$tbl}} ){
my $alt_indexes = $self->{alt_index_usage}->{$query_id}->{$db}->{$tbl}->{$index};
foreach my $alt_index ( keys %$alt_indexes ) {
my $cnt = $alt_indexes->{$alt_index};
$insert_index_alt_sth->execute(
$query_id, $db, $tbl, $index, $alt_index, $cnt, $cnt);
}
}
}
}
}
$dbh->commit unless $dbh->{AutoCommit};
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 IndexUsage package
# ###########################################################################
# ###########################################################################
# Progress package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Progress.pm
# t/lib/Progress.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Progress;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
foreach my $arg (qw(jobsize)) {
die "I need a $arg argument" unless defined $args{$arg};
}
if ( (!$args{report} || !$args{interval}) ) {
if ( $args{spec} && @{$args{spec}} == 2 ) {
@args{qw(report interval)} = @{$args{spec}};
}
else {
die "I need either report and interval arguments, or a spec";
}
}
my $name = $args{name} || "Progress";
$args{start} ||= time();
my $self;
$self = {
last_reported => $args{start},
fraction => 0, # How complete the job is
callback => sub {
my ($fraction, $elapsed, $remaining) = @_;
printf STDERR "$name: %3d%% %s remain\n",
$fraction * 100,
Transformers::secs_to_time($remaining);
},
%args,
};
return bless $self, $class;
}
sub validate_spec {
shift @_ if $_[0] eq 'Progress'; # Permit calling as Progress-> or Progress::
my ( $spec ) = @_;
if ( @$spec != 2 ) {
die "spec array requires a two-part argument\n";
}
if ( $spec->[0] !~ m/^(?:percentage|time|iterations)$/ ) {
die "spec array's first element must be one of "
. "percentage,time,iterations\n";
}
if ( $spec->[1] !~ m/^\d+$/ ) {
die "spec array's second element must be an integer\n";
}
}
sub set_callback {
my ( $self, $callback ) = @_;
$self->{callback} = $callback;
}
sub start {
my ( $self, $start ) = @_;
$self->{start} = $self->{last_reported} = $start || time();
$self->{first_report} = 0;
}
sub update {
my ( $self, $callback, %args ) = @_;
my $jobsize = $self->{jobsize};
my $now ||= $args{now} || time;
$self->{iterations}++; # How many updates have happened;
if ( !$self->{first_report} && $args{first_report} ) {
$args{first_report}->();
$self->{first_report} = 1;
}
if ( $self->{report} eq 'time'
&& $self->{interval} > $now - $self->{last_reported}
) {
return;
}
elsif ( $self->{report} eq 'iterations'
&& ($self->{iterations} - 1) % $self->{interval} > 0
) {
return;
}
$self->{last_reported} = $now;
my $completed = $callback->();
$self->{updates}++; # How many times we have run the update callback
return if $completed > $jobsize;
my $fraction = $completed > 0 ? $completed / $jobsize : 0;
if ( $self->{report} eq 'percentage'
&& $self->fraction_modulo($self->{fraction})
>= $self->fraction_modulo($fraction)
) {
$self->{fraction} = $fraction;
return;
}
$self->{fraction} = $fraction;
my $elapsed = $now - $self->{start};
my $remaining = 0;
my $eta = $now;
if ( $completed > 0 && $completed <= $jobsize && $elapsed > 0 ) {
my $rate = $completed / $elapsed;
if ( $rate > 0 ) {
$remaining = ($jobsize - $completed) / $rate;
$eta = $now + int($remaining);
}
}
$self->{callback}->($fraction, $elapsed, $remaining, $eta, $completed);
}
sub fraction_modulo {
my ( $self, $num ) = @_;
$num *= 100; # Convert from fraction to percentage
return sprintf('%d',
sprintf('%d', $num / $self->{interval}) * $self->{interval});
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Progress package
# ###########################################################################
# ###########################################################################
# HTTP::Micro package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/HTTP/Micro.pm
# t/lib/HTTP/Micro.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package HTTP::Micro;
our $VERSION = '0.01';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent timeout);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $agent = $class) =~ s{::}{-}g;
my $self = {
agent => $agent . "/" . ($class->VERSION || 0),
timeout => 60,
};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
return bless $self, $class;
}
my %DefaultPort = (
http => 80,
https => 443,
);
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
$args ||= {}; # we keep some state in this during _request
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $method eq 'GET'
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
$handle->connect($scheme, $host, $port);
$self->_prepare_headers_and_cb($request, $args);
$handle->write_request_header(@{$request}{qw/method uri headers/});
$handle->write_content_body($request) if $request->{content};
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
$response->{content} = '';
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args) = @_;
for ($args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if (defined $args->{content}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
utf8::downgrade($args->{content}, 1)
or Carp::croak(q/Wide character in request message body/);
$request->{headers}{'content-length'} = length $args->{content};
$request->{content} = $args->{content};
}
return;
}
sub _split_url {
my $url = pop;
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or Carp::croak(qq/Cannot parse URL: '$url'/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: $DefaultPort{$scheme}
};
return ($scheme, $host, $port, $path_query);
}
} # HTTP::Micro
{
package HTTP::Micro::Handle;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp qw(croak);
use Errno qw(EINTR EPIPE);
use IO::Socket qw(SOCK_STREAM);
sub BUFSIZE () { 32768 }
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
my $ssl_verify_args = {
check_cn => "when_only",
wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere"
};
sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
eval "require IO::Socket::SSL"
unless exists $INC{'IO/Socket/SSL.pm'};
croak(qq/IO::Socket::SSL must be installed for https support\n/)
unless $INC{'IO/Socket/SSL.pm'};
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = IO::Socket::INET->new(
PeerHost => $host,
PeerPort => $port,
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh})
or croak(qq/Could not binmode() socket: '$!'/);
if ( $scheme eq 'https') {
IO::Socket::SSL->start_SSL($self->{fh});
ref($self->{fh}) eq 'IO::Socket::SSL'
or die(qq/SSL connection failed for $host\n/);
if ( $self->{fh}->can("verify_hostname") ) {
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
or die(qq/SSL certificate not valid for $host\n/);
}
else {
my $fh = $self->{fh};
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
or die(qq/SSL certificate not valid for $host\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_;
CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/);
}
sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_;
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or croak(q/Timed out while waiting for socket to become ready for writing/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
croak(qq/Socket closed by remote server: $!/);
}
elsif ($! != EINTR) {
croak(qq/Could not write to socket: '$!'/);
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
if ($len) {
croak(q/Unexpected end of stream/);
}
return $buf;
}
sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
croak(q/Unexpected end of stream while looking for line/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
$val = \($headers->{$field_name} = $2);
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or croak(q/Unexpected header continuation line/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
$field_name =~ s/\b(\w)/\u$1/g;
$buf .= "$field_name: $v\x0D\x0A";
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_content_body {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $len) = @_;
$len ||= $response->{headers}{'content-length'};
croak("No content-length in the returned response, and this "
. "UA doesn't implement chunking") unless defined $len;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read), $response);
$len -= $read;
}
return;
}
sub write_content_body {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
$len += $self->write($request->{content});
$len == $content_length
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len;
}
sub read_response_header {
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or croak(q/Malformed Status-Line: / . $Printable->($line));
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or croak(q/select(2): 'Bad file descriptor'/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or croak(qq/select(2): '$!'/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift;
return $self->_do_timeout('write', @_)
}
} # HTTP::Micro::Handle
my $prog = <<'EOP';
BEGIN {
if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
*CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
}
else {
constant->import( CAN_IPV6 => '' );
}
my %const = (
NID_CommonName => 13,
GEN_DNS => 2,
GEN_IPADD => 7,
);
while ( my ($name,$value) = each %const ) {
no strict 'refs';
*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
}
}
{
use Carp qw(croak);
my %dispatcher = (
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
);
if ( $Net::SSLeay::VERSION >= 1.30 ) {
$dispatcher{commonName} = sub {
my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
$cn;
}
} else {
$dispatcher{commonName} = sub {
croak "you need at least Net::SSLeay version 1.30 for getting commonName"
}
}
if ( $Net::SSLeay::VERSION >= 1.33 ) {
$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
} else {
$dispatcher{subjectAltNames} = sub {
return;
};
}
$dispatcher{authority} = $dispatcher{issuer};
$dispatcher{owner} = $dispatcher{subject};
$dispatcher{cn} = $dispatcher{commonName};
sub _peer_certificate {
my ($self, $field) = @_;
my $ssl = $self->_get_ssl_object or return;
my $cert = ${*$self}{_SSL_certificate}
||= Net::SSLeay::get_peer_certificate($ssl)
or return $self->error("Could not retrieve peer certificate");
if ($field) {
my $sub = $dispatcher{$field} or croak
"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
"\nMaybe you need to upgrade your Net::SSLeay";
return $sub->($cert);
} else {
return $cert
}
}
my %scheme = (
ldap => {
wildcards_in_cn => 0,
wildcards_in_alt => 'leftmost',
check_cn => 'always',
},
http => {
wildcards_in_cn => 'anywhere',
wildcards_in_alt => 'anywhere',
check_cn => 'when_only',
},
smtp => {
wildcards_in_cn => 0,
wildcards_in_alt => 0,
check_cn => 'always'
},
none => {}, # do not check
);
$scheme{www} = $scheme{http}; # alias
$scheme{xmpp} = $scheme{http}; # rfc 3920
$scheme{pop3} = $scheme{ldap}; # rfc 2595
$scheme{imap} = $scheme{ldap}; # rfc 2595
$scheme{acap} = $scheme{ldap}; # rfc 2595
$scheme{nntp} = $scheme{ldap}; # rfc 4642
$scheme{ftp} = $scheme{http}; # rfc 4217
sub _verify_hostname_of_cert {
my $identity = shift;
my $cert = shift;
my $scheme = shift || 'none';
if ( ! ref($scheme) ) {
$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
}
return 1 if ! %$scheme; # 'none'
my $commonName = $dispatcher{cn}->($cert);
my @altNames = $dispatcher{subjectAltNames}->($cert);
if ( my $sub = $scheme->{callback} ) {
return $sub->($identity,$commonName,@altNames);
}
my $ipn;
if ( CAN_IPV6 and $identity =~m{:} ) {
$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
} else {
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
$identity =~m{\0} and croak("name '$identity' has \\0 byte");
$identity = IO::Socket::SSL::idn_to_ascii($identity) or
croak "Warning: Given name '$identity' could not be converted to IDNA!";
}
}
my $check_name = sub {
my ($name,$identity,$wtyp) = @_;
$wtyp ||= '';
my $pattern;
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
} else {
$pattern = qr{^\Q$name\E$}i;
}
return $identity =~ $pattern;
};
my $alt_dnsNames = 0;
while (@altNames) {
my ($type, $name) = splice (@altNames, 0, 2);
if ( $ipn and $type == GEN_IPADD ) {
return 1 if $ipn eq $name;
} elsif ( ! $ipn and $type == GEN_DNS ) {
$name =~s/\s+$//; $name =~s/^\s+//;
$alt_dnsNames++;
$check_name->($name,$identity,$scheme->{wildcards_in_alt})
and return 1;
}
}
if ( ! $ipn and (
$scheme->{check_cn} eq 'always' or
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
and return 1;
}
return 0; # no match
}
}
EOP
eval { require IO::Socket::SSL };
if ( $INC{"IO/Socket/SSL.pm"} ) {
eval $prog;
die $@ if $@;
}
1;
# ###########################################################################
# End HTTP::Micro package
# ###########################################################################
# ###########################################################################
# VersionCheck package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionCheck.pm
# t/lib/VersionCheck.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionCheck;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
use Digest::MD5 qw(md5_hex);
use Sys::Hostname qw(hostname);
use File::Basename qw();
use File::Spec;
use FindBin qw();
eval {
require Percona::Toolkit;
require HTTP::Micro;
};
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my @vc_dirs = (
'/etc/percona',
'/etc/percona-toolkit',
'/tmp',
"$home",
);
{
my $file = 'percona-version-check';
sub version_check_file {
foreach my $dir ( @vc_dirs ) {
if ( -d $dir && -w $dir ) {
PTDEBUG && _d('Version check file', $file, 'in', $dir);
return $dir . '/' . $file;
}
}
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
return $file; # in the CWD
}
}
sub version_check_time_limit {
return 60 * 60 * 24; # one day
}
sub version_check {
my (%args) = @_;
my $instances = $args{instances} || [];
my $instances_to_check;
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
if ( !$args{force} ) {
if ( $FindBin::Bin
&& (-d "$FindBin::Bin/../.bzr" ||
-d "$FindBin::Bin/../../.bzr" ||
-d "$FindBin::Bin/../.git" ||
-d "$FindBin::Bin/../../.git"
)
) {
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
return;
}
}
eval {
foreach my $instance ( @$instances ) {
my ($name, $id) = get_instance_id($instance);
$instance->{name} = $name;
$instance->{id} = $id;
}
push @$instances, { name => 'system', id => 0 };
$instances_to_check = get_instances_to_check(
instances => $instances,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
return unless @$instances_to_check;
my $protocol = 'https';
eval { require IO::Socket::SSL; };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
PTDEBUG && _d("SSL not available, won't run version_check");
return;
}
PTDEBUG && _d('Using', $protocol);
my $advice = pingback(
instances => $instances_to_check,
protocol => $protocol,
url => $args{url} # testing
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
|| "$protocol://v.percona.com",
);
if ( $advice ) {
PTDEBUG && _d('Advice:', Dumper($advice));
if ( scalar @$advice > 1) {
print "\n# " . scalar @$advice . " software updates are "
. "available:\n";
}
else {
print "\n# A software update is available:\n";
}
print join("\n", map { "# * $_" } @$advice), "\n\n";
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
}
if ( @$instances_to_check ) {
eval {
update_check_times(
instances => $instances_to_check,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
}
}
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
warn "Exiting because the PTDEBUG_VERSION_CHECK "
. "environment variable is defined.\n";
exit 255;
}
return;
}
sub get_instances_to_check {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
if ( !-f $vc_file ) {
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
'version checking all instances');
return $instances;
}
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
chomp(my $file_contents = do { local $/ = undef; <$fh> });
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
close $fh;
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
my $check_time_limit = version_check_time_limit();
my @instances_to_check;
foreach my $instance ( @$instances ) {
my $last_check_time = $last_check_time_for{ $instance->{id} };
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
'hours until next check',
sprintf '%.2f',
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
if ( !defined $last_check_time
|| ($now - $last_check_time) >= $check_time_limit ) {
PTDEBUG && _d('Time to check', Dumper($instance));
push @instances_to_check, $instance;
}
}
return \@instances_to_check;
}
sub update_check_times {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
PTDEBUG && _d('Updating last check time:', $now);
my %all_instances = map {
$_->{id} => { name => $_->{name}, ts => $now }
} @$instances;
if ( -f $vc_file ) {
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
foreach my $line ( split("\n", ($contents || '')) ) {
my ($id, $ts) = split(',', $line);
if ( !exists $all_instances{$id} ) {
$all_instances{$id} = { ts => $ts }; # original ts, not updated
}
}
}
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
foreach my $id ( sort keys %all_instances ) {
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
}
close $fh;
return;
}
sub get_instance_id {
my ($instance) = @_;
my $dbh = $instance->{dbh};
my $dsn = $instance->{dsn};
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
PTDEBUG && _d($sql);
my ($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$sql = q{SELECT @@hostname};
PTDEBUG && _d($sql);
($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
}
else {
$sql = q{SHOW VARIABLES LIKE 'port'};
PTDEBUG && _d($sql);
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
PTDEBUG && _d('port:', $port);
$name .= $port || '';
}
}
my $id = md5_hex($name);
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
return $name, $id;
}
sub get_uuid {
my $uuid_file = '/.percona-toolkit.uuid';
foreach my $dir (@vc_dirs) {
my $filename = $dir.$uuid_file;
my $uuid=_read_uuid($filename);
return $uuid if $uuid;
}
my $filename = $ENV{"HOME"} . $uuid_file;
my $uuid = _generate_uuid();
open(my $fh, '>', $filename) or die "Could not open file '$filename' $!";
print $fh $uuid;
close $fh;
return $uuid;
}
sub _generate_uuid {
return sprintf+($}="%04x")."$}-$}-$}-$}-".$}x3,map rand 65537,0..7;
}
sub _read_uuid {
my $filename = shift;
my $fh;
eval {
open($fh, '<:encoding(UTF-8)', $filename);
};
return if ($EVAL_ERROR);
my $uuid;
eval { $uuid = <$fh>; };
return if ($EVAL_ERROR);
chomp $uuid;
return $uuid;
}
sub pingback {
my (%args) = @_;
my @required_args = qw(url instances);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my $url = $args{url};
my $instances = $args{instances};
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
my $response = $ua->request('GET', $url);
PTDEBUG && _d('Server response:', Dumper($response));
die "No response from GET $url"
if !$response;
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
($response->{content} || '')) if $response->{status} != 200;
die("GET on $url did not return any programs to check")
if !$response->{content};
my $items = parse_server_response(
response => $response->{content}
);
die "Failed to parse server requested programs: $response->{content}"
if !scalar keys %$items;
my $versions = get_versions(
items => $items,
instances => $instances,
);
die "Failed to get any program versions; should have at least gotten Perl"
if !scalar keys %$versions;
my $client_content = encode_client_response(
items => $items,
versions => $versions,
general_id => get_uuid(),
);
my $client_response = {
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
content => $client_content,
};
PTDEBUG && _d('Client response:', Dumper($client_response));
$response = $ua->request('POST', $url, $client_response);
PTDEBUG && _d('Server suggestions:', Dumper($response));
die "No response from POST $url $client_response"
if !$response;
die "POST $url returned HTTP status $response->{status}; expected 200"
if $response->{status} != 200;
return unless $response->{content};
$items = parse_server_response(
response => $response->{content},
split_vars => 0,
);
die "Failed to parse server suggestions: $response->{content}"
if !scalar keys %$items;
my @suggestions = map { $_->{vars} }
sort { $a->{item} cmp $b->{item} }
values %$items;
return \@suggestions;
}
sub encode_client_response {
my (%args) = @_;
my @required_args = qw(items versions general_id);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items, $versions, $general_id) = @args{@required_args};
my @lines;
foreach my $item ( sort keys %$items ) {
next unless exists $versions->{$item};
if ( ref($versions->{$item}) eq 'HASH' ) {
my $mysql_versions = $versions->{$item};
for my $id ( sort keys %$mysql_versions ) {
push @lines, join(';', $id, $item, $mysql_versions->{$id});
}
}
else {
push @lines, join(';', $general_id, $item, $versions->{$item});
}
}
my $client_response = join("\n", @lines) . "\n";
return $client_response;
}
sub parse_server_response {
my (%args) = @_;
my @required_args = qw(response);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($response) = @args{@required_args};
my %items = map {
my ($item, $type, $vars) = split(";", $_);
if ( !defined $args{split_vars} || $args{split_vars} ) {
$vars = [ split(",", ($vars || '')) ];
}
$item => {
item => $item,
type => $type,
vars => $vars,
};
} split("\n", $response);
PTDEBUG && _d('Items:', Dumper(\%items));
return \%items;
}
my %sub_for_type = (
os_version => \&get_os_version,
perl_version => \&get_perl_version,
perl_module_version => \&get_perl_module_version,
mysql_variable => \&get_mysql_variable,
);
sub valid_item {
my ($item) = @_;
return unless $item;
if ( !exists $sub_for_type{ $item->{type} } ) {
PTDEBUG && _d('Invalid type:', $item->{type});
return 0;
}
return 1;
}
sub get_versions {
my (%args) = @_;
my @required_args = qw(items);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items) = @args{@required_args};
my %versions;
foreach my $item ( values %$items ) {
next unless valid_item($item);
eval {
my $version = $sub_for_type{ $item->{type} }->(
item => $item,
instances => $args{instances},
);
if ( $version ) {
chomp $version unless ref($version);
$versions{$item->{item}} = $version;
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
}
}
return \%versions;
}
sub get_os_version {
if ( $OSNAME eq 'MSWin32' ) {
require Win32;
return Win32::GetOSDisplayName();
}
chomp(my $platform = `uname -s`);
PTDEBUG && _d('platform:', $platform);
return $OSNAME unless $platform;
chomp(my $lsb_release
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
PTDEBUG && _d('lsb_release:', $lsb_release);
my $release = "";
if ( $platform eq 'Linux' ) {
if ( -f "/etc/fedora-release" ) {
$release = `cat /etc/fedora-release`;
}
elsif ( -f "/etc/redhat-release" ) {
$release = `cat /etc/redhat-release`;
}
elsif ( -f "/etc/system-release" ) {
$release = `cat /etc/system-release`;
}
elsif ( $lsb_release ) {
$release = `$lsb_release -ds`;
}
elsif ( -f "/etc/lsb-release" ) {
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
$release =~ s/^\w+="([^"]+)".+/$1/;
}
elsif ( -f "/etc/debian_version" ) {
chomp(my $rel = `cat /etc/debian_version`);
$release = "Debian $rel";
if ( -f "/etc/apt/sources.list" ) {
chomp(my $code_name = `awk '/^deb/ {print \$3}' /etc/apt/sources.list | awk -F/ '{print \$1}'| awk 'BEGIN {FS="|"} {print \$1}' | sort | uniq -c | sort -rn | head -n1 | awk '{print \$2}'`);
$release .= " ($code_name)" if $code_name;
}
}
elsif ( -f "/etc/os-release" ) { # openSUSE
chomp($release = `grep PRETTY_NAME /etc/os-release`);
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
}
elsif ( `ls /etc/*release 2>/dev/null` ) {
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
}
else {
$release = `cat /etc/*release | head -n1`;
}
}
}
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
my $rel = `uname -r`;
$release = "$platform $rel";
}
elsif ( $platform eq "SunOS" ) {
my $rel = `head -n1 /etc/release` || `uname -r`;
$release = "$platform $rel";
}
if ( !$release ) {
PTDEBUG && _d('Failed to get the release, using platform');
$release = $platform;
}
chomp($release);
$release =~ s/^"|"$//g;
PTDEBUG && _d('OS version =', $release);
return $release;
}
sub get_perl_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $version = sprintf '%vd', $PERL_VERSION;
PTDEBUG && _d('Perl version', $version);
return $version;
}
sub get_perl_module_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $var = '$' . $item->{item} . '::VERSION';
my $version = eval "use $item->{item}; $var;";
PTDEBUG && _d('Perl version for', $var, '=', $version);
return $version;
}
sub get_mysql_variable {
return get_from_mysql(
show => 'VARIABLES',
@_,
);
}
sub get_from_mysql {
my (%args) = @_;
my $show = $args{show};
my $item = $args{item};
my $instances = $args{instances};
return unless $show && $item;
if ( !$instances || !@$instances ) {
PTDEBUG && _d('Cannot check', $item,
'because there are no MySQL instances');
return;
}
if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
@{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
}
my @versions;
my %version_for;
foreach my $instance ( @$instances ) {
next unless $instance->{id}; # special system instance has id=0
my $dbh = $instance->{dbh};
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $sql = qq/SHOW $show/;
PTDEBUG && _d($sql);
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
my @versions;
foreach my $var ( @{$item->{vars}} ) {
$var = lc($var);
my $version = $rows->{$var}->{value};
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
'on', $instance->{name});
push @versions, $version;
}
$version_for{ $instance->{id} } = join(' ', @versions);
}
return \%version_for;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End VersionCheck package
# ###########################################################################
# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check just above main() for the call to main() which actually runs the
# program.
# ###########################################################################
package pt_index_usage;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$OUTPUT_AUTOFLUSH = 1;
use Percona::Toolkit;
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
Transformers->import(qw(make_checksum));
# Global variables. Only really essential variables should be here.
my $oktorun = 1;
sub main {
local @ARGV = @_; # set global ARGV for this package
$oktorun = 1;
# ##########################################################################
# Get configuration information.
# ##########################################################################
my $o = new OptionParser();
$o->get_specs();
$o->get_opts();
my $dp = $o->DSNParser();
$dp->prop('set-vars', $o->set_vars());
$o->set('progress', undef) if $o->get('q');
if ( !$o->got('help') ) {
if ( $o->get('progress') ) {
eval { Progress->validate_spec($o->get('progress')) };
if ( $EVAL_ERROR ) {
chomp $EVAL_ERROR;
$o->save_error("--progress $EVAL_ERROR");
}
}
if ( my $dsn = $o->get('save-results-database') ) {
if ( !$dsn->{D} ) {
$o->save_error("You must specify a D (database) part for the "
. "--save-results-database DSN");
}
}
}
$o->usage_or_errors();
# ##########################################################################
# Open the database connections. If no connection opts (-h, -P, etc.)
# are given on the cmd line then parse_options() will return undef,
# but get_cxn() required a defined dsn arg so use an empty hashref.
# ##########################################################################
my ($dsn, $dbh, $si_dbh, $res_dbh);
my $res_dsn;
my $res_db;
eval {
$dsn = $dp->parse_options($o) || {};
# dbh for EXPLAIN-ing.
$dbh = get_cxn(
dsn => $dsn,
OptionParser => $o,
DSNParser => $dp,
);
# dbh for SchemaIterator
# http://code.google.com/p/maatkit/issues/detail?id=1140
$si_dbh = get_cxn(
dsn => $dsn,
OptionParser => $o,
DSNParser => $dp,
);
# dbh for --save-results-database
if ( $res_dsn = $o->get('save-results-database') ) {
# To make --create-save-results-database work we have to
# temporarily remove the D from the DSN to avoid the error
# "DBI connect failed: Unknown database". It's restored
# to the DSN after connecting.
$res_db = $res_dsn->{D};
$res_dsn->{D} = undef if $o->get('create-save-results-database');
$res_dbh = get_cxn(
dsn => $res_dsn,
OptionParser => $o,
DSNParser => $dp,
);
$res_dsn->{D} = $res_db;
}
};
if ( $EVAL_ERROR ) {
# Avoid "Issuing rollback() for database handle being DESTROY'd
# without explicit disconnect()" errors.
$dbh->disconnect if $dbh;
$si_dbh->disconnect if $si_dbh;
$res_dbh->disconnect if $res_dbh;
die $EVAL_ERROR;
}
# ##########################################################################
# Make common modules.
# ##########################################################################
my $q = new Quoter();
my $qp = new QueryParser();
my $qr = new QueryRewriter(QueryParser => $qp);
my $tp = new TableParser(Quoter => $q);
my $parser = new SlowLogParser();
my $fi = new FileIterator();
my $iu = new IndexUsage(
QueryRewriter => $qr,
);
my $exa = new ExplainAnalyzer(
QueryRewriter => $qr,
QueryParser => $qp
);
my %common_modules = (
OptionParser => $o,
DSNParser => $dp,
Quoter => $q,
QueryParser => $qp,
QueryRewriter => $qr,
TableParser => $tp,
IndexUsage => $iu,
ExplainAnalyzer => $exa,
);
# ########################################################################
# Ready the save results database and its tables.
# ########################################################################
if ( $res_dbh ) {
my $db = $o->get('save-results-database')->{D}; # checked earlier
# Create the database (if it doesn't already exist).
if ( $o->get('create-save-results-database') ) {
create_save_results_database(
dbh => $res_dbh,
db => $db,
%common_modules,
);
}
# Parse the CREATE TABLE defs from the POD.
my @tables = get_save_results_tables(%common_modules);
# Empty the tables. This is actually done via DROP TABLE IF EXISTS.
if ( $o->get('empty-save-results-tables') ) {
empty_save_results_tables(
dbh => $res_dbh,
db => $db,
tbls => \@tables,
%common_modules,
);
}
# Create the tables if necessary. If they were dropped above, now
# they'll be recreated. If they never existed (e.g. new db), they'll
# be recreated. Or if they already exist, each def has "IF NOT EXISTS"
# so existing tables will remain untouched.
create_save_results_tables(
dbh => $res_dbh,
db => $db,
tbls => \@tables,
%common_modules,
);
# Create views for the canned/example queries.
# http://code.google.com/p/maatkit/issues/detail?id=1184
if ( $o->get('create-views') ) {
eval {
create_views(
dbh => $res_dbh,
db => $db,
%common_modules,
);
};
if ( $EVAL_ERROR ) {
warn "Failed to create views: $EVAL_ERROR";
}
}
}
# ########################################################################
# Do the version-check
# ########################################################################
if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
VersionCheck::version_check(
force => $o->got('version-check'),
instances => [
{ dbh => $dbh, dsn => $dsn },
($res_dbh ? { dbh => $res_dbh, dsn => $res_dsn } : ())
],
);
}
# ########################################################################
# Populate the IndexUsage object with indexes. Also get a list of all
# databases and tables before going on to parse the queries. This will be
# important when we see a query without any default database, and we have to
# guess which database to USE for EXPLAIN-ing it. This code block doesn't
# read query logs, it's just inventorying the tables and indexes.
# ########################################################################
my $schema = new Schema();
my $schema_itr = new SchemaIterator(
dbh => $si_dbh,
OptionParser => $o,
Quoter => $q,
TableParser => $tp,
Schema => $schema,
);
TALBE:
while ( my $tbl = $schema_itr->next() ) {
eval {
my $ddl = $tbl->{ddl};
if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) {
$ddl = $tp->ansi_to_legacy($ddl);
}
my ($indexes) = $tp->get_keys($ddl, {});
$iu->add_indexes(%$tbl, indexes=>$indexes);
};
if ( $EVAL_ERROR ) {
warn $EVAL_ERROR unless $o->get('q');
PTDEBUG && _d($EVAL_ERROR);
}
}
$si_dbh->disconnect();
# ########################################################################
# This keeps track of the $dbh's current DB, so we know when to USE a
# different database.
# ########################################################################
my $cur_db = $o->get('database') || '';
# ########################################################################
# This keeps track of statements that can't be EXPLAINed for some reason, so
# they are not tried again.
# ########################################################################
my %err_for = ();
# ########################################################################
# This is the main loop over the input filenames.
# ########################################################################
my $next_file = $fi->get_file_itr(@ARGV);
my ( $fh, $filename, $filesize ) = $next_file->();
FILE:
while ( defined $fh ) {
# Create a callback to get events from the slow query log file.
my $next_event = sub { return <$fh>; };
my $tell = sub { return tell $fh; };
my $event;
my $get_event = sub {
return $parser->parse_event(
event => $event,
next_event => $next_event,
tell => $tell,
oktorun => sub { return 1 },
misc => {},
stats => {},
);
};
# #####################################################################
# Set up a progress reporter. For right now, we just do one per file.
# Maybe someday we can do a global progress report?
# #####################################################################
my $pr;
if ( $o->get('progress') && $filename && -e $filename ) {
$pr = new Progress(
jobsize => -s $filename,
spec => $o->get('progress'),
name => $filename,
);
}
# #####################################################################
# This is the main loop over the queries in the log. For each query we
# are going to store what we learn about that query's EXPLAIN plan, keyed
# off its fingerprint.
# #####################################################################
EVENT:
while ( $event = $get_event->() ) {
my $arg = $event->{arg} or next EVENT; # The arg is the SQL.
my $fingerprint = $event->{fingerprint} = $qr->fingerprint($arg);
# Skip events that previously had an error.
next if $err_for{$fingerprint};
eval {
# Checksum the query and get the query's ID.
my $chk = make_checksum($arg);
my $id = make_checksum($fingerprint);
# Do we need to USE a new database before we EXPLAIN the query?
my $new_db = $event->{db} || $event->{Schema};
if ( $new_db && $new_db ne $cur_db ) {
my $sql = 'USE ' . $q->quote($new_db);
PTDEBUG && _d($sql);
$dbh->do($sql);
$cur_db = $new_db;
}
# See if we've EXPLAINed this checksum before. If so, just
# increment counters with the saved info from $exa. If not, EXPLAIN
# and increment counters, then save to $exa.
my $access = $exa->get_usage_for($chk, $cur_db);
if ( !$access ) {
# The query might not be explain-able. If that is so, it will
# die, and we want that to happen so it gets blacklisted. We
# don't want it to return an error or something like that, and we
# don't want to filter it out and skip it in the first place,
# because then we will keep burning cycles on it trying to
# explain it over and over.
my $explain = $exa->explain_query(
dbh => $dbh,
query => $arg,
);
$access = $exa->get_index_usage(
query => $arg,
db => $cur_db,
explain => $exa->normalize($explain),
);
$exa->save_usage_for($chk, $cur_db, $access);
$iu->add_query(
query_id => $id,
fingerprint => $fingerprint,
sample => $arg,
);
}
foreach my $row ( @$access ) {
$iu->add_table_usage($row->{db}, $row->{tbl});
$iu->add_index_usage(
usage => $access,
query_id => $id,
);
}
};
if ( $EVAL_ERROR ) {
# Skip statements with this fingerprint in the future (blacklist).
$err_for{$fingerprint} = { event => $event, error => $EVAL_ERROR };
# Log the error.
PTDEBUG && _d('Problem on query', $event, $EVAL_ERROR);
warn $EVAL_ERROR unless $o->get('q');
}
$pr->update($tell) if $pr;
} # EVENT
( $fh, $filename, $filesize ) = $next_file->();
} # FILE
# ########################################################################
# All done! Now print the reports, maybe.
# ########################################################################
if ( $res_dbh ) {
$iu->save_results(
dbh => $res_dbh,
db => $res_db,
);
}
if ( $o->get('report') ) {
print_reports(
dbh => $dbh,
err_for => \%err_for,
%common_modules
);
}
$dbh->disconnect;
$res_dbh->disconnect if $res_dbh;
return 0;
} # End main().
# ############################################################################
# Subroutines.
# ############################################################################
sub print_reports {
my ( %args ) = @_;
my $iu = $args{IndexUsage};
my $o = $args{OptionParser};
my @reports = @{$o->get('report-format')};
PTDEBUG && _d("Printing reports");
if ( grep { $_ eq 'drop_unused_indexes' } @reports ) {
$iu->find_unused_indexes(
sub {
my ( $unused ) = @_;
print_unused_indexes(
unused => $unused,
drop => $o->get('drop'),
%args,
);
}
);
}
return;
}
sub print_unused_indexes {
my ( %args ) = @_;
my @required_args = qw(unused drop Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($unused, $drop, $q) = @args{@required_args};
my $db_tbl = $q->quote($unused->{db}, $unused->{tbl});
# We must ignore the types that we're not dropping, then group
# indexes of the remaining types together and print them together.
my (@primary, @unique, @nonunique);
foreach my $idx ( @{$unused->{idx}} ) {
if ($idx->{name} =~ m/PRIMARY/i ) {
push @primary, $idx;
}
elsif ( $idx->{is_unique} ) {
push @unique, $idx;
}
else {
push @nonunique, $idx;
}
}
print_alter_drop_key(
db_tbl => $db_tbl,
idx => \@primary,
type => 'primary key',
%args
) if $drop->{primary} || $drop->{all};
print_alter_drop_key(
db_tbl => $db_tbl,
idx => \@unique,
type => 'unique',
%args
) if $drop->{unique} || $drop->{all};
print_alter_drop_key(
db_tbl => $db_tbl,
idx => \@nonunique,
type => 'non-unique',
%args
) if $drop->{"non-unique"} || $drop->{all};
return;
}
sub print_alter_drop_key {
my ( %args ) = @_;
my @required_args = qw(db_tbl idx Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($db_tbl, $idx, $q) = @args{@required_args};
return unless @$idx;
print "\nALTER TABLE $db_tbl "
. join(', ', map { "DROP KEY " . $q->quote($_->{name}) } @$idx)
. ";"
. ($args{type} ? " -- type:$args{type}" : "")
. "\n";
return;
}
sub get_cxn {
my ( %args ) = @_;
my @required_args = qw(dsn OptionParser DSNParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dsn, $o, $dp) = @args{@required_args};
if ( $o->get('ask-pass') ) {
$dsn->{p} = OptionParser::prompt_noecho("Enter password "
. ($args{for} ? "for $args{for}: " : ": "));
}
my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn), $args{opts});
PTDEBUG && _d('Connected dbh', $dbh);
return $dbh;
}
sub create_save_results_database {
my ( %args ) = @_;
my @required_args = qw(dbh db Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($dbh, $db, $q) = @args{@required_args};
my $sql;
$db = $q->quote($db);
eval {
PTDEBUG && _d("Checking if", $db, "database already exists");
$sql = "USE $db";
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d($db, "does not exist:", $EVAL_ERROR);
$sql = "CREATE DATABASE $db";
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
# Now USE the newly created db (the first attempt failed obviously).
$sql = "USE $db";
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
else {
PTDEBUG && _d($db, "already exists");
}
return;
}
sub get_save_results_tables {
my ( %args ) = @_;
my @required_args = qw(OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($o) = @args{@required_args};
my $file = $args{file} || __FILE__;
PTDEBUG && _d("Getting CREATE TABLE defs from POD");
my @table_defs = qw(indexes tables queries index_usage index_alternatives);
my @tables;
foreach my $tbl ( @table_defs ) {
my $magic = "MAGIC_create_$tbl";
my $sql = $o->read_para_after($file, qr/$magic/);
push @tables, {
name => $tbl,
def => $sql,
};
}
return @tables;
}
sub empty_save_results_tables {
my ( %args ) = @_;
my @required_args = qw(dbh db tbls Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($dbh, $db, $tbls, $q) = @args{@required_args};
foreach my $tbl ( @$tbls ) {
# Nothing is more "empty" than non-existence. The tables
# will be recreated later by calling create_save_results_tables().
# Dropping and recreating has an advantage over truncating/deleting:
# if the CREATE TABLE def is changed, this will auto-upgrade.
my $sql = "DROP TABLE IF EXISTS " . $q->quote($db, $tbl->{name});
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
return;
}
sub create_save_results_tables {
my ( %args ) = @_;
my @required_args = qw(dbh db tbls);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($dbh, $db, $tbls) = @args{@required_args};
foreach my $tbl ( @$tbls ) {
my $sql = $tbl->{def};
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
return;
}
sub create_views {
my ( %args ) = @_;
my @required_args = qw(dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($dbh) = @args{@required_args};
PTDEBUG && _d("Creating views");
my $pod_parser = new PodParser();
$pod_parser->parse_from_file(__FILE__);
my $magic = $pod_parser->get_magic('OPTIONS');
foreach my $ident ( keys %$magic ) {
next unless $ident =~ m/^view/;
my $sql = "CREATE VIEW `$ident` AS $magic->{$ident}";
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
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-index-usage - Read queries from a log and analyze how they use indexes.
=head1 SYNOPSIS
Usage: pt-index-usage [OPTIONS] [FILES]
pt-index-usage reads queries from logs and analyzes how they use indexes.
Analyze queries in slow.log and print reports:
pt-index-usage /path/to/slow.log --host localhost
Disable reports and save results to percona database for later analysis:
pt-index-usage slow.log --no-report --save-results-database percona
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
This tool connects to a MySQL database server, reads through a query log, and
uses EXPLAIN to ask MySQL how it will use each query. When it is finished, it
prints out a report on indexes that the queries didn't use.
The query log needs to be in MySQL's slow query log format. If you need to
input a different format, you can use L<pt-query-digest> to translate the
formats. If you don't specify a filename, the tool reads from STDIN.
The tool runs two stages. In the first stage, the tool takes inventory of all
the tables and indexes in your database, so it can compare the existing indexes
to those that were actually used by the queries in the log. In the second
stage, it runs EXPLAIN on each query in the query log. It uses separate
database connections to inventory the tables and run EXPLAIN, so it opens two
connections to the database.
If a query is not a SELECT, it tries to transform it to a roughly equivalent
SELECT query so it can be EXPLAINed. This is not a perfect process, but it is
good enough to be useful.
The tool skips the EXPLAIN step for queries that are exact duplicates of those
seen before. It assumes that the same query will generate the same EXPLAIN plan
as it did previously (usually a safe assumption, and generally good for
performance), and simply increments the count of times that the indexes were
used. However, queries that have the same fingerprint but different checksums
will be re-EXPLAINed. Queries that have different literal constants can have
different execution plans, and this is important to measure.
After EXPLAIN-ing the query, it is necessary to try to map aliases in the query
back to the original table names. For example, consider the EXPLAIN plan for
the following query:
SELECT * FROM tbl1 AS foo;
The EXPLAIN output will show access to table C<foo>, and that must be translated
back to C<tbl1>. This process involves complex parsing. It is generally very
accurate, but there is some chance that it might not work right. If you find
cases where it fails, submit a bug report and a reproducible test case.
Queries that cannot be EXPLAINed will cause all subsequent queries with the
same fingerprint to be blacklisted. This is to reduce the work they cause, and
prevent them from continuing to print error messages. However, at least in
this stage of the tool's development, it is my opinion that it's not a good
idea to preemptively silence these, or prevent them from being EXPLAINed at
all. I am looking for lots of feedback on how to improve things like the
query parsing. So please submit your test cases based on the errors the tool
prints!
=head1 OUTPUT
After it reads all the events in the log, the tool prints out DROP statements
for every index that was not used. It skips indexes for tables that were never
accessed by any queries in the log, to avoid false-positive results.
If you don't specify L<"--quiet">, the tool also outputs warnings about
statements that cannot be EXPLAINed and similar. These go to standard error.
Progress reports are enabled by default (see L<"--progress">). These also go to
standard error.
=head1 OPTIONS
This tool accepts additional command-line arguments. Refer to the
L<"SYNOPSIS"> and usage information for details.
=over
=item --ask-pass
Prompt for a password when connecting to MySQL.
=item --charset
short form: -A; type: string
Default character set. If the value is utf8, sets Perl's binmode on
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and
runs SET NAMES UTF8 after connecting to MySQL. Any other value sets
binmode on STDOUT without the utf8 layer, and runs SET NAMES after
connecting to MySQL.
=item --config
type: Array
Read this comma-separated list of config files; if specified, this must be the
first option on the command line.
=item --create-save-results-database
Create the L<"--save-results-database"> if it does not exist.
If the L<"--save-results-database"> already exists and this option is
specified, the database is used and the necessary tables are created if
they do not already exist.
=item --[no]create-views
Create views for L<"--save-results-database"> example queries.
Several example queries are given for querying the tables in the
L<"--save-results-database">. These example queries are, by default, created
as views. Specifying C<--no-create-views> prevents these views from being
created.
=item --database
short form: -D; type: string
The database to use for the connection.
=item --databases
short form: -d; type: hash
Only get tables and indexes from this comma-separated list of databases.
=item --databases-regex
type: string
Only get tables and indexes from database whose names match this Perl regex.
=item --defaults-file
short form: -F; type: string
Only read mysql options from the given file. You must give an absolute pathname.
=item --drop
type: Hash; default: non-unique
Suggest dropping only these types of unused indexes.
By default pt-index-usage will only suggest to drop unused secondary indexes,
not primary or unique indexes. You can specify which types of unused indexes
the tool suggests to drop: primary, unique, non-unique, all.
A separate C<ALTER TABLE> statement for each type is printed. So if you
specify C<--drop all> and there is a primary key and a non-unique index,
the C<ALTER TABLE ... DROP> for each will be printed on separate lines.
=item --empty-save-results-tables
Drop and re-create all pre-existing tables in the L<"--save-results-database">.
This allows information from previous runs to be removed before the current run.
=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-databases-regex
type: string
Ignore databases whose names match this Perl regex.
=item --ignore-tables
type: Hash
Ignore this comma-separated list of table names.
Table names may be qualified with the database name.
=item --ignore-tables-regex
type: string
Ignore tables whose names match the Perl regex.
=item --password
short form: -p; type: string
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item --port
short form: -P; type: int
Port number to use for connection.
=item --progress
type: array; default: time,30
Print progress reports to STDERR. The value is a comma-separated list with two
parts. The first part can be percentage, time, or iterations; the second part
specifies how often an update should be printed, in percentage, seconds, or
number of iterations.
=item --quiet
short form: -q
Do not print any warnings. Also disables L<"--progress">.
=item --[no]report
default: yes
Print the reports for L<"--report-format">.
You may want to disable the reports by specifying C<--no-report> if, for
example, you also specify L<"--save-results-database"> and you only want
to query the results tables later.
=item --report-format
type: Array; default: drop_unused_indexes
Right now there is only one report: drop_unused_indexes. This report prints
SQL statements for dropping any unused indexes. See also L<"--drop">.
See also L<"--[no]report">.
=item --save-results-database
type: DSN
Save results to tables in this database. Information about indexes, queries,
tables and their usage is stored in several tables in the specified database.
The tables are auto-created if they do not exist. If the database doesn't
exist, it can be auto-created with L<"--create-save-results-database">. In this
case the connection is initially created with no default database, then after
the database is created, it is USE'ed.
pt-index-usage executes INSERT statements to save the results. Therefore, you
should be careful if you use this feature on a production server. It might
increase load, or cause trouble if you don't want the server to be written to,
or so on.
This is a new feature. It may change in future releases.
After a run, you can query the usage tables to answer various questions about
index usage. The tables have the following CREATE TABLE definitions:
MAGIC_create_indexes:
CREATE TABLE IF NOT EXISTS indexes (
db VARCHAR(64) NOT NULL,
tbl VARCHAR(64) NOT NULL,
idx VARCHAR(64) NOT NULL,
cnt BIGINT UNSIGNED NOT NULL DEFAULT 0,
PRIMARY KEY (db, tbl, idx)
)
MAGIC_create_queries:
CREATE TABLE IF NOT EXISTS queries (
query_id BIGINT UNSIGNED NOT NULL,
fingerprint TEXT NOT NULL,
sample TEXT NOT NULL,
PRIMARY KEY (query_id)
)
MAGIC_create_tables:
CREATE TABLE IF NOT EXISTS tables (
db VARCHAR(64) NOT NULL,
tbl VARCHAR(64) NOT NULL,
cnt BIGINT UNSIGNED NOT NULL DEFAULT 0,
PRIMARY KEY (db, tbl)
)
MAGIC_create_index_usage:
CREATE TABLE IF NOT EXISTS index_usage (
query_id BIGINT UNSIGNED NOT NULL,
db VARCHAR(64) NOT NULL,
tbl VARCHAR(64) NOT NULL,
idx VARCHAR(64) NOT NULL,
cnt BIGINT UNSIGNED NOT NULL DEFAULT 1,
UNIQUE INDEX (query_id, db, tbl, idx)
)
MAGIC_create_index_alternatives:
CREATE TABLE IF NOT EXISTS index_alternatives (
query_id BIGINT UNSIGNED NOT NULL, -- This query used
db VARCHAR(64) NOT NULL, -- this index, but...
tbl VARCHAR(64) NOT NULL, --
idx VARCHAR(64) NOT NULL, --
alt_idx VARCHAR(64) NOT NULL, -- was an alternative
cnt BIGINT UNSIGNED NOT NULL DEFAULT 1,
UNIQUE INDEX (query_id, db, tbl, idx, alt_idx),
INDEX (db, tbl, idx),
INDEX (db, tbl, alt_idx)
)
The following are some queries you can run against these tables to answer common
questions you might have. Each query is also created as a view (with MySQL
v5.0 and newer) if C<"--[no]create-views"> is true (it is by default).
The view names are the strings after the C<MAGIC_view_> prefix.
Question: which queries sometimes use different indexes, and what fraction of
the time is each index chosen? MAGIC_view_query_uses_several_indexes:
SELECT iu.query_id, CONCAT_WS('.', iu.db, iu.tbl, iu.idx) AS idx,
variations, iu.cnt, iu.cnt / total_cnt * 100 AS pct
FROM index_usage AS iu
INNER JOIN (
SELECT query_id, db, tbl, SUM(cnt) AS total_cnt,
COUNT(*) AS variations
FROM index_usage
GROUP BY query_id, db, tbl
HAVING COUNT(*) > 1
) AS qv USING(query_id, db, tbl);
Question: which indexes have lots of alternatives, i.e. are chosen instead of
other indexes, and for what queries? MAGIC_view_index_has_alternates:
SELECT CONCAT_WS('.', db, tbl, idx) AS idx_chosen,
GROUP_CONCAT(DISTINCT alt_idx) AS alternatives,
GROUP_CONCAT(DISTINCT query_id) AS queries, SUM(cnt) AS cnt
FROM index_alternatives
GROUP BY db, tbl, idx
HAVING COUNT(*) > 1;
Question: which indexes are considered as alternates for other indexes, and for
what queries? MAGIC_view_index_alternates:
SELECT CONCAT_WS('.', db, tbl, alt_idx) AS idx_considered,
GROUP_CONCAT(DISTINCT idx) AS alternative_to,
GROUP_CONCAT(DISTINCT query_id) AS queries, SUM(cnt) AS cnt
FROM index_alternatives
GROUP BY db, tbl, alt_idx
HAVING COUNT(*) > 1;
Question: which of those are never chosen by any queries, and are therefore
superfluous? MAGIC_view_unused_index_alternates:
SELECT CONCAT_WS('.', i.db, i.tbl, i.idx) AS idx,
alt.alternative_to, alt.queries, alt.cnt
FROM indexes AS i
INNER JOIN (
SELECT db, tbl, alt_idx, GROUP_CONCAT(DISTINCT idx) AS alternative_to,
GROUP_CONCAT(DISTINCT query_id) AS queries, SUM(cnt) AS cnt
FROM index_alternatives
GROUP BY db, tbl, alt_idx
HAVING COUNT(*) > 1
) AS alt ON i.db = alt.db AND i.tbl = alt.tbl
AND i.idx = alt.alt_idx
WHERE i.cnt = 0;
Question: given a table, which indexes were used, by how many queries, with how
many distinct fingerprints? Were there alternatives? Which indexes were not
used? You can edit the following query's SELECT list to also see the query IDs
in question. MAGIC_view_index_usage:
SELECT i.idx, iu.usage_cnt, iu.usage_total,
ia.alt_cnt, ia.alt_total
FROM indexes AS i
LEFT OUTER JOIN (
SELECT db, tbl, idx, COUNT(*) AS usage_cnt,
SUM(cnt) AS usage_total, GROUP_CONCAT(query_id) AS used_by
FROM index_usage
GROUP BY db, tbl, idx
) AS iu ON i.db=iu.db AND i.tbl=iu.tbl AND i.idx = iu.idx
LEFT OUTER JOIN (
SELECT db, tbl, idx, COUNT(*) AS alt_cnt,
SUM(cnt) AS alt_total,
GROUP_CONCAT(query_id) AS alt_queries
FROM index_alternatives
GROUP BY db, tbl, idx
) AS ia ON i.db=ia.db AND i.tbl=ia.tbl AND i.idx = ia.idx;
Question: which indexes on a given table are vital for at least one query (there
is no alternative)? MAGIC_view_required_indexes:
SELECT i.db, i.tbl, i.idx, no_alt.queries
FROM indexes AS i
INNER JOIN (
SELECT iu.db, iu.tbl, iu.idx,
GROUP_CONCAT(iu.query_id) AS queries
FROM index_usage AS iu
LEFT OUTER JOIN index_alternatives AS ia
USING(db, tbl, idx)
WHERE ia.db IS NULL
GROUP BY iu.db, iu.tbl, iu.idx
) AS no_alt ON no_alt.db = i.db AND no_alt.tbl = i.tbl
AND no_alt.idx = i.idx
ORDER BY i.db, i.tbl, i.idx, no_alt.queries;
=item --set-vars
type: Array
Set the MySQL variables in this comma-separated list of C<variable=value> pairs.
By default, the tool sets:
=for comment ignore-pt-internal-value
MAGIC_set_vars
wait_timeout=10000
Variables specified on the command line override these defaults. For
example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>.
The tool prints a warning and continues if a variable cannot be set.
=item --socket
short form: -S; type: string
Socket file to use for connection.
=item --tables
short form: -t; type: hash
Only get indexes from this comma-separated list of tables.
=item --tables-regex
type: string
Only get indexes from tables whose names match this Perl regex.
=item --user
short form: -u; type: string
User for login if not current user.
=item --version
Show version and exit.
=item --[no]version-check
default: yes
Check for the latest version of Percona Toolkit, MySQL, and other programs.
This is a standard "check for updates automatically" feature, with two
additional features. First, the tool checks its own version and also the
versions of the following software: operating system, Percona Monitoring and
Management (PMM), MySQL, Perl, MySQL driver for Perl (DBD::mysql), and
Percona Toolkit. Second, it checks for and warns about versions with known
problems. For example, MySQL 5.5.25 had a critical bug and was re-released
as 5.5.25a.
A secure connection to Percona’s Version Check database server is done to
perform these checks. Each request is logged by the server, including software
version numbers and unique ID of the checked system. The ID is generated by the
Percona Toolkit installation script or when the Version Check database call is
done for the first time.
Any updates or known problems are printed to STDOUT before the tool's normal
output. This feature should never interfere with the normal operation of the
tool.
For more information, visit L<https://www.percona.com/doc/percona-toolkit/LATEST/version-check.html>.
=back
=head1 DSN OPTIONS
These DSN options are used to create a DSN. Each option is given like
C<option=value>. The options are case-sensitive, so P and p are not the
same option. There cannot be whitespace before or after the C<=> and
if the value contains whitespace it must be quoted. DSN options are
comma-separated. See the L<percona-toolkit> manpage for full details.
=over
=item * A
dsn: charset; copy: yes
Default character set.
=item * D
dsn: database; copy: yes
Database to connect to.
=item * F
dsn: mysql_read_default_file; copy: yes
Only read default options from the given file
=item * h
dsn: host; copy: yes
Connect to host.
=item * p
dsn: password; copy: yes
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item * P
dsn: port; copy: yes
Port number to use for connection.
=item * S
dsn: mysql_socket; copy: yes
Socket file to use for connection.
=item * u
dsn: user; copy: yes
User for login if not current user.
=back
=head1 ENVIRONMENT
The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
To enable debugging and capture all output to a file, run the tool like:
PTDEBUG=1 pt-index-usage ... > 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-index-usage>.
Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C<PTDEBUG>;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L<http://www.percona.com/software/percona-toolkit/> to download the
latest release of Percona Toolkit. Or, get the latest release from the
command line:
wget percona.com/get/percona-toolkit.tar.gz
wget percona.com/get/percona-toolkit.rpm
wget percona.com/get/percona-toolkit.deb
You can also get individual tools from the latest release:
wget percona.com/get/TOOL
Replace C<TOOL> with the name of any tool.
=head1 AUTHORS
Baron Schwartz and Daniel Nichter
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools for MySQL developed by Percona. Percona Toolkit was forked from two
projects in June, 2011: Maatkit and Aspersa. Those projects were created by
Baron Schwartz and primarily developed by him and Daniel Nichter. Visit
L<http://www.percona.com/software/> to learn about other free, open-source
software from Percona.
=head1 COPYRIGHT, LICENSE, AND WARRANTY
This program is copyright 2011-2018 Percona LLC and/or its affiliates,
2010-2011 Baron Schwartz.
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-index-usage 3.0.11
=cut
Reference in New Issue View Git Blame Copy Permalink