diff --git a/bin/pt-archiver b/bin/pt-archiver index d26e4c2f..548bcd39 100755 --- a/bin/pt-archiver +++ b/bin/pt-archiver @@ -1033,6 +1033,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # TableParser package # This package is a copy without comments from the original. The original @@ -1337,7 +1787,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -1852,96 +2302,137 @@ sub _d { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -1979,6 +2470,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -2770,8 +3262,7 @@ sub get_connected_slaves { my $show = "SHOW GRANTS FOR "; my $user = 'CURRENT_USER()'; - my $vp = $self->{VersionParser}; - if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2' ) { $user = $dbh->selectrow_arrayref('SELECT USER()')->[0]; $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/; } @@ -3298,7 +3789,6 @@ my ( $src, $dst ); # Holds the arguments for the $sth's bind variables, so it can be re-tried # easily. my @beginning_of_txn; -my $vp = new VersionParser; my $q = new Quoter; sub main { @@ -3554,7 +4044,7 @@ sub main { my $dsn_defaults = $dp->parse_options($o); my $dsn = $dp->parse($o->get('check-slave-lag'), $dsn_defaults); $lag_dbh = $dp->get_dbh($dp->get_cxn_params($dsn), { AutoCommit => 1 }); - $ms = new MasterSlave(VersionParser => $vp); + $ms = new MasterSlave(); } # ######################################################################## @@ -3627,7 +4117,7 @@ sub main { . join(',', map { $q->quote($_) } @{$sel_stmt->{cols}} ) . " FROM $src->{db_tbl}" . ( $sel_stmt->{index} - ? (($vp->version_ge($dbh, '4.0.9') ? " FORCE" : " USE") + ? ((VersionParser->new($dbh) >= '4.0.9' ? " FORCE" : " USE") . " INDEX(`$sel_stmt->{index}`)") : '') . " WHERE (".$o->get('where').")"; @@ -4327,7 +4817,7 @@ sub ts { sub get_irot { my ( $dbh ) = @_; - return 1 unless $vp->version_ge($dbh, '5.0.13'); + return 1 unless VersionParser->new($dbh) >= '5.0.13'; my $rows = $dbh->selectall_arrayref( "show variables like 'innodb_rollback_on_timeout'", { Slice => {} }); diff --git a/bin/pt-deadlock-logger b/bin/pt-deadlock-logger index 584c0f87..c2017a2f 100755 --- a/bin/pt-deadlock-logger +++ b/bin/pt-deadlock-logger @@ -1033,6 +1033,455 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### # ########################################################################### # VersionParser package # This package is a copy without comments from the original. The original @@ -1044,96 +1493,137 @@ if ( PTDEBUG ) { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -1171,6 +1661,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -1919,7 +2410,6 @@ sub main { @ARGV = @_; # set global ARGV for this package my $q = new Quoter(); - my $vp = new VersionParser(); # ######################################################################## # Get configuration information. @@ -2072,7 +2562,7 @@ sub main { $dbh->{AutoCommit} = 0; my $sql = $o->read_para_after(__FILE__, qr/MAGIC_clear_deadlocks/); - if ( !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2') { $sql =~ s/ENGINE=/TYPE=/; } $sql =~ s/test.deadlock_maker/$db_tbl/; diff --git a/bin/pt-duplicate-key-checker b/bin/pt-duplicate-key-checker index ef52152b..753703be 100755 --- a/bin/pt-duplicate-key-checker +++ b/bin/pt-duplicate-key-checker @@ -8,6 +8,456 @@ use strict; use warnings FATAL => 'all'; use constant PTDEBUG => $ENV{PTDEBUG} || 0; +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # VersionParser package # This package is a copy without comments from the original. The original @@ -19,96 +469,137 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0; { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -146,6 +637,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -575,7 +1067,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -3517,8 +4009,7 @@ sub main { my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn), { AutoCommit => 1, }); - my $vp = new VersionParser(); - my $version = $vp->parse($dbh->selectrow_array('SELECT VERSION()')); + my $version = VersionParser->new($dbh); # ####################################################################### # Do the main work. @@ -3550,7 +4041,7 @@ sub main { my ($keys, $clustered_key, $fks); if ( $get_keys ) { ($keys, $clustered_key) - = $tp->get_keys($tbl->{ddl}, {version => $version}); + = $tp->get_keys($tbl->{ddl}, {mysql_version => $version}); } if ( $get_fks ) { $fks = $tp->get_fks($tbl->{ddl}, {database => $tbl->{db}}); diff --git a/bin/pt-find b/bin/pt-find index 91fb1f4d..a12527b6 100755 --- a/bin/pt-find +++ b/bin/pt-find @@ -1394,6 +1394,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # Quoter package # This package is a copy without comments from the original. The original @@ -1524,96 +1974,137 @@ sub deserialize_list { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -1651,6 +2142,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -1961,7 +2453,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -2689,8 +3181,7 @@ sub main { ($server_id) = $dbh->selectrow_array('SELECT @@SERVER_ID'); # Discover if we need to get stored code. Need dbh to do this. - my $vp = new VersionParser(); - my $need_stored_code = $vp->version_ge($dbh, '5.0.0'); + my $need_stored_code = VersionParser->new($dbh) >= '5.0.0'; $need_stored_code = grep { $o->got($_); } @stored_code_tests if $need_stored_code; PTDEBUG && _d('Need stored code:', $need_stored_code); diff --git a/bin/pt-heartbeat b/bin/pt-heartbeat index a56d8a22..b3a17667 100755 --- a/bin/pt-heartbeat +++ b/bin/pt-heartbeat @@ -222,8 +222,7 @@ sub get_connected_slaves { my $show = "SHOW GRANTS FOR "; my $user = 'CURRENT_USER()'; - my $vp = $self->{VersionParser}; - if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2' ) { $user = $dbh->selectrow_arrayref('SELECT USER()')->[0]; $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/; } @@ -1741,6 +1740,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # DSNParser package # This package is a copy without comments from the original. The original @@ -2422,96 +2871,137 @@ sub deserialize_list { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -2549,6 +3039,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -2859,7 +3350,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -3548,8 +4039,7 @@ sub main { my $master_server_id = $o->get('master-server-id'); if ( !$master_server_id ) { eval { - my $vp = new VersionParser(); - my $ms = new MasterSlave(VersionParser => $vp); + my $ms = new MasterSlave(); my $master_dsn = $ms->get_master_dsn($dbh, $dsn, $dp) or die "This server is not a slave"; my $master_dbh = $dp->get_dbh($dp->get_cxn_params($master_dsn), @@ -3876,8 +4366,7 @@ sub check_delay { # Collect a list of connections to the slaves. if ( $o->get('recurse') ) { PTDEBUG && _d('Recursing to slaves'); - my $vp = new VersionParser(); - my $ms = new MasterSlave(VersionParser => $vp); + my $ms = new MasterSlave(); $ms->recurse_to_slaves( { dbh => $dbh, dsn => $dsn, diff --git a/bin/pt-index-usage b/bin/pt-index-usage index aa5ce211..07a23fdf 100755 --- a/bin/pt-index-usage +++ b/bin/pt-index-usage @@ -1513,6 +1513,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # PodParser package # This package is a copy without comments from the original. The original @@ -3006,7 +3456,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -3508,96 +3958,137 @@ sub _d { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -3635,6 +4126,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -5068,7 +5560,6 @@ sub main { my $qp = new QueryParser(); my $qr = new QueryRewriter(QueryParser => $qp); my $tp = new TableParser(Quoter => $q); - my $vp = new VersionParser(); my $parser = new SlowLogParser(); my $fi = new FileIterator(); my $iu = new IndexUsage( @@ -5085,7 +5576,6 @@ sub main { QueryParser => $qp, QueryRewriter => $qr, TableParser => $tp, - VersionParser => $vp, IndexUsage => $iu, ExplainAnalyzer => $exa, ); @@ -5152,7 +5642,7 @@ sub main { # 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 $version = $vp->parse($dbh->selectrow_array('SELECT VERSION()')); + my $version = VersionParser->new($dbh); my $schema = new Schema(); my $schema_itr = new SchemaIterator( @@ -5169,7 +5659,7 @@ sub main { if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) { $ddl = $tp->ansi_to_legacy($ddl); } - my ($indexes) = $tp->get_keys($ddl, {version => $version}); + my ($indexes) = $tp->get_keys($ddl, {mysql_version => $version}); $iu->add_indexes(%$tbl, indexes=>$indexes); }; if ( $EVAL_ERROR ) { diff --git a/bin/pt-kill b/bin/pt-kill index 920a3ce4..d2aca332 100755 --- a/bin/pt-kill +++ b/bin/pt-kill @@ -1034,147 +1034,453 @@ if ( PTDEBUG ) { # ########################################################################### # ########################################################################### -# VersionParser package +# Mo package # This package is a copy without comments from the original. The original # with comments and its test file can be found in the Bazaar repository at, -# lib/VersionParser.pm -# t/lib/VersionParser.t +# lib/Mo.pm +# t/lib/Mo.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { -package VersionParser; +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; +use warnings qw( FATAL all ); -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use Carp (); +use Scalar::Util (); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +our %metadata_for; +{ + package Mo::Object; - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); -} - -sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; -} - -sub innodb_version { - my ( $self, $dbh ) = @_; - return unless $dbh; - my $innodb_version = "NO"; - - my ($innodb) = - grep { $_->{engine} =~ m/InnoDB/i } - map { - my %hash; - @hash{ map { lc $_ } keys %$_ } = values %$_; - \%hash; + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } } - @{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) }; - if ( $innodb ) { - PTDEBUG && _d("InnoDB support:", $innodb->{support}); - if ( $innodb->{support} =~ m/YES|DEFAULT/i ) { - my $vars = $dbh->selectrow_hashref( - "SHOW VARIABLES LIKE 'innodb_version'"); - $innodb_version = !$vars ? "BUILTIN" - : ($vars->{Value} || $vars->{value}); + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always } else { - $innodb_version = $innodb->{support}; # probably DISABLED or NO + $ref = { @_ }; } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); } - PTDEBUG && _d("InnoDB version:", $innodb_version); - return $innodb_version; + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } } -sub _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"; +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } } +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} 1; } # ########################################################################### -# End VersionParser package +# End Mo package # ########################################################################### # ########################################################################### @@ -2790,8 +3096,7 @@ sub get_connected_slaves { my $show = "SHOW GRANTS FOR "; my $user = 'CURRENT_USER()'; - my $vp = $self->{VersionParser}; - if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2' ) { $user = $dbh->selectrow_arrayref('SELECT USER()')->[0]; $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/; } @@ -3711,7 +4016,6 @@ sub main { my $ms = new MasterSlave(); my $pl = new Processlist(MasterSlave => $ms); - my $vp = new VersionParser(); my $qr = new QueryRewriter(); # ######################################################################## diff --git a/bin/pt-online-schema-change b/bin/pt-online-schema-change index e450a65d..94ce1329 100755 --- a/bin/pt-online-schema-change +++ b/bin/pt-online-schema-change @@ -1033,6 +1033,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # VersionParser package # This package is a copy without comments from the original. The original @@ -1044,96 +1494,137 @@ if ( PTDEBUG ) { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -1171,6 +1662,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -2413,7 +2905,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -3140,8 +3632,7 @@ sub get_connected_slaves { my $show = "SHOW GRANTS FOR "; my $user = 'CURRENT_USER()'; - my $vp = $self->{VersionParser}; - if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2' ) { $user = $dbh->selectrow_arrayref('SELECT USER()')->[0]; $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/; } @@ -5484,8 +5975,7 @@ sub main { # Although triggers were introduced in 5.0.2, "Prior to MySQL 5.0.10, # triggers cannot contain direct references to tables by name." # ######################################################################## - my $vp = new VersionParser(); - if ( !$vp->version_ge($cxn->dbh(), '5.0.10') ) { + if ( VersionParser->new($cxn->dbh()) < '5.0.10' ) { die "This tool requires MySQL 5.0.10 or newer.\n"; } diff --git a/bin/pt-slave-delay b/bin/pt-slave-delay index 8ebe47f6..ca3280dd 100755 --- a/bin/pt-slave-delay +++ b/bin/pt-slave-delay @@ -1034,147 +1034,453 @@ if ( PTDEBUG ) { # ########################################################################### # ########################################################################### -# VersionParser package +# Mo package # This package is a copy without comments from the original. The original # with comments and its test file can be found in the Bazaar repository at, -# lib/VersionParser.pm -# t/lib/VersionParser.t +# lib/Mo.pm +# t/lib/Mo.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { -package VersionParser; +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} use strict; -use warnings FATAL => 'all'; -use English qw(-no_match_vars); -use constant PTDEBUG => $ENV{PTDEBUG} || 0; +use warnings qw( FATAL all ); -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use Carp (); +use Scalar::Util (); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +our %metadata_for; +{ + package Mo::Object; - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); -} - -sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; -} - -sub innodb_version { - my ( $self, $dbh ) = @_; - return unless $dbh; - my $innodb_version = "NO"; - - my ($innodb) = - grep { $_->{engine} =~ m/InnoDB/i } - map { - my %hash; - @hash{ map { lc $_ } keys %$_ } = values %$_; - \%hash; + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } } - @{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) }; - if ( $innodb ) { - PTDEBUG && _d("InnoDB support:", $innodb->{support}); - if ( $innodb->{support} =~ m/YES|DEFAULT/i ) { - my $vars = $dbh->selectrow_hashref( - "SHOW VARIABLES LIKE 'innodb_version'"); - $innodb_version = !$vars ? "BUILTIN" - : ($vars->{Value} || $vars->{value}); + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always } else { - $innodb_version = $innodb->{support}; # probably DISABLED or NO + $ref = { @_ }; } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); } - PTDEBUG && _d("InnoDB version:", $innodb_version); - return $innodb_version; + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } } -sub _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"; +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } } +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} 1; } # ########################################################################### -# End VersionParser package +# End Mo package # ########################################################################### # ########################################################################### @@ -2179,7 +2485,6 @@ my $oktorun = 1; sub main { @ARGV = @_; # set global ARGV for this package - my $vp = new VersionParser(); $o = new OptionParser(); $o->get_specs(); $o->get_opts(); diff --git a/bin/pt-slave-find b/bin/pt-slave-find index 3a416746..4fe482ee 100755 --- a/bin/pt-slave-find +++ b/bin/pt-slave-find @@ -1033,6 +1033,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # DSNParser package # This package is a copy without comments from the original. The original @@ -1608,8 +2058,7 @@ sub get_connected_slaves { my $show = "SHOW GRANTS FOR "; my $user = 'CURRENT_USER()'; - my $vp = $self->{VersionParser}; - if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2' ) { $user = $dbh->selectrow_arrayref('SELECT USER()')->[0]; $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/; } @@ -2303,96 +2752,137 @@ sub _d { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -2430,6 +2920,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -2850,8 +3341,7 @@ sub main { # Despite the name, recursing to slaves actually begins at the specified # server, so the named server may also be included. - my $vp = new VersionParser(); - my $ms = new MasterSlave(VersionParser => $vp); + my $ms = new MasterSlave(); $ms->recurse_to_slaves( { dbh => $dbh, dsn => $master_dsn, @@ -2888,7 +3378,6 @@ sub main { node => $root, print_node => $print_node, MasterSlave => $ms, - VersionParser => $vp, ); return 0; @@ -2951,8 +3440,8 @@ sub print_node_hostname { sub print_node_summary { my ( %args ) = @_; - my ($ms, $vp, $node, $level) - = @args{qw(MasterSlave VersionParser node level)}; + my ($ms, $node, $level) + = @args{qw(MasterSlave node level)}; die "I need a node" unless $node; $level ||= 0; @@ -3023,7 +3512,7 @@ sub print_node_summary { . ", offset " . ($vars->{auto_increment_offset}->{value} || '') ]; - my $innodb_version = $vp->innodb_version($dbh); + my $innodb_version = VersionParser->new($dbh)->innodb_version(); push @lines, ['InnoDB version', $innodb_version]; my $line_fmt = "$indent%-15s %s"; diff --git a/bin/pt-slave-restart b/bin/pt-slave-restart index 6bbda77d..7b897e51 100755 --- a/bin/pt-slave-restart +++ b/bin/pt-slave-restart @@ -1152,6 +1152,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # VersionParser package # This package is a copy without comments from the original. The original @@ -1163,96 +1613,137 @@ if ( PTDEBUG ) { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -1290,6 +1781,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -1871,8 +2363,7 @@ sub get_connected_slaves { my $show = "SHOW GRANTS FOR "; my $user = 'CURRENT_USER()'; - my $vp = $self->{VersionParser}; - if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2' ) { $user = $dbh->selectrow_arrayref('SELECT USER()')->[0]; $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/; } @@ -2578,7 +3069,6 @@ $OUTPUT_AUTOFLUSH = 1; my $o; my $dp; my $q = new Quoter(); -my $vp = new VersionParser(); my %children; sub main { @@ -2674,7 +3164,7 @@ sub main { # Despite the name, recursing to slaves actually begins at the specified # server, so the named server may also be watched, if it's a slave. - my $ms = new MasterSlave(VersionParser => $vp); + my $ms = new MasterSlave(); $ms->recurse_to_slaves( { dbh => $dbh, dsn => $dsn, @@ -2750,7 +3240,7 @@ sub watch_server { PTDEBUG && _d('Watching server', $dp->as_string($dsn), 'forked:', $was_forked); - my $start_sql = $vp->version_ge($dbh, '4.0.5') + my $start_sql = VersionParser->new($dbh) >= '4.0.5' ? 'START SLAVE' : 'SLAVE START'; if ( $o->get('until-master') ) { my ( $file, $pos ) = split(',', $o->get('until-master')); diff --git a/bin/pt-table-checksum b/bin/pt-table-checksum index 0a87c20d..eceaf5d1 100755 --- a/bin/pt-table-checksum +++ b/bin/pt-table-checksum @@ -1394,6 +1394,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # Cxn package # This package is a copy without comments from the original. The original @@ -1668,96 +2118,137 @@ sub deserialize_list { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -1795,6 +2286,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -2105,7 +2597,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -2724,8 +3216,7 @@ sub get_connected_slaves { my $show = "SHOW GRANTS FOR "; my $user = 'CURRENT_USER()'; - my $vp = $self->{VersionParser}; - if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2' ) { $user = $dbh->selectrow_arrayref('SELECT USER()')->[0]; $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/; } @@ -6374,7 +6865,6 @@ sub main { # ######################################################################## # Connect to the master. # ######################################################################## - my $vp = new VersionParser(); my $set_on_connect = sub { my ($dbh) = @_; @@ -6386,7 +6876,7 @@ sub main { # instead, it should check if it's already set to STATEMENT. # This is becase starting with MySQL 5.1.29, changing the format # requires a SUPER user. - if ( $vp->version_ge($dbh, '5.1.5') ) { + if ( VersionParser->new($dbh) >= '5.1.5' ) { $sql = 'SELECT @@binlog_format'; PTDEBUG && _d($dbh, $sql); my ($original_binlog_format) = $dbh->selectrow_array($sql); @@ -6508,7 +6998,7 @@ sub main { my $q = new Quoter(); my $tp = new TableParser(Quoter => $q); my $rc = new RowChecksum(Quoter=> $q, OptionParser => $o); - my $ms = new MasterSlave(VersionParser => $vp); + my $ms = new MasterSlave(); my $slaves; # all slaves (that we can find) my $slave_lag_cxns; # slaves whose lag we'll check diff --git a/bin/pt-table-sync b/bin/pt-table-sync index 4536f528..81c29fa2 100755 --- a/bin/pt-table-sync +++ b/bin/pt-table-sync @@ -1033,6 +1033,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # Quoter package # This package is a copy without comments from the original. The original @@ -1524,96 +1974,137 @@ sub _d { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -1651,6 +2142,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -2080,7 +2572,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -3994,7 +4486,7 @@ our %ALGOS = ( sub new { my ( $class, %args ) = @_; - foreach my $arg ( qw(Quoter VersionParser) ) { + foreach my $arg ( qw(Quoter) ) { die "I need a $arg argument" unless defined $args{$arg}; } my $self = { %args }; @@ -4050,21 +4542,22 @@ sub get_crc_type { sub best_algorithm { my ( $self, %args ) = @_; my ( $alg, $dbh ) = @args{ qw(algorithm dbh) }; - my $vp = $self->{VersionParser}; my @choices = sort { $ALGOS{$a}->{pref} <=> $ALGOS{$b}->{pref} } keys %ALGOS; die "Invalid checksum algorithm $alg" if $alg && !$ALGOS{$alg}; + my $version = VersionParser->new($dbh); + if ( $args{where} || $args{chunk} # CHECKSUM does whole table || $args{replicate} # CHECKSUM can't do INSERT.. SELECT - || !$vp->version_ge($dbh, '4.1.1')) # CHECKSUM doesn't exist + || $version < '4.1.1') # CHECKSUM doesn't exist { PTDEBUG && _d('Cannot use CHECKSUM algorithm'); @choices = grep { $_ ne 'CHECKSUM' } @choices; } - if ( !$vp->version_ge($dbh, '4.1.1') ) { + if ( $version < '4.1.1' ) { PTDEBUG && _d('Cannot use BIT_XOR algorithm because MySQL < 4.1.1'); @choices = grep { $_ ne 'BIT_XOR' } @choices; } @@ -5191,7 +5684,7 @@ $Data::Dumper::Quotekeys = 0; sub new { my ( $class, %args ) = @_; - my @required_args = qw(MasterSlave Quoter VersionParser TableChecksum Retry); + my @required_args = qw(MasterSlave Quoter TableChecksum Retry); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless defined $args{$arg}; } @@ -5244,7 +5737,6 @@ sub sync_table { $args{timeout_ok} ||= 0; my $q = $self->{Quoter}; - my $vp = $self->{VersionParser}; my ($plugin, %plugin_args) = $self->get_best_plugin(%args); die "No plugin can sync $src->{db}.$src->{tbl}" unless $plugin; @@ -5256,8 +5748,8 @@ sub sync_table { PTDEBUG && _d('CRC column:', $crc_col); my $index_hint; - my $hint = ($vp->version_ge($src->{dbh}, '4.0.9') - && $vp->version_ge($dst->{dbh}, '4.0.9') ? 'FORCE' : 'USE') + my $hint = ((VersionParser->new($src->{dbh}) >= '4.0.9' + && VersionParser->new($dst->{dbh}) >= '4.0.9') ? 'FORCE' : 'USE') . ' INDEX'; if ( $args{chunk_index} ) { PTDEBUG && _d('Using given chunk index for index hint'); @@ -6158,8 +6650,7 @@ sub get_connected_slaves { my $show = "SHOW GRANTS FOR "; my $user = 'CURRENT_USER()'; - my $vp = $self->{VersionParser}; - if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) { + if ( VersionParser->new($dbh) < '4.1.2' ) { $user = $dbh->selectrow_arrayref('SELECT USER()')->[0]; $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/; } @@ -7739,7 +8230,6 @@ sub main { # ######################################################################## # Get configuration information. # ######################################################################## - my $vp = new VersionParser(); my $o = new OptionParser(); $o->get_specs(); $o->get_opts(); @@ -7850,15 +8340,14 @@ sub main { # Do the work. # ######################################################################## my $tp = new TableParser( Quoter => $q ); - my $ms = new MasterSlave(VersionParser => $vp); + my $ms = new MasterSlave(); my $du = new MySQLDump( cache => 0 ); my $rt = new Retry(); my $chunker = new TableChunker( Quoter => $q, TableParser => $tp ); my $nibbler = new TableNibbler( Quoter => $q, TableParser => $tp ); - my $checksum = new TableChecksum( Quoter => $q, VersionParser => $vp ); + my $checksum = new TableChecksum( Quoter => $q ); my $syncer = new TableSyncer( Quoter => $q, - VersionParser => $vp, MasterSlave => $ms, TableChecksum => $checksum, DSNParser => $dp, @@ -7870,7 +8359,6 @@ sub main { MySQLDump => $du, TableParser => $tp, Quoter => $q, - VersionParser => $vp, TableChunker => $chunker, TableNibbler => $nibbler, TableChecksum => $checksum, @@ -7974,8 +8462,7 @@ sub main { # Exit status sub lock_and_rename { my ( %args ) = @_; - my @required_args = qw(dsns plugins OptionParser DSNParser Quoter - VersionParser); + my @required_args = qw(dsns plugins OptionParser DSNParser Quoter ); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } @@ -8000,9 +8487,8 @@ sub lock_and_rename { tbl => $dsns->[1]->{t}, }; - my $vp = VersionParser->new(); my %options = ( DSNParser => $dp, OptionParser => $o ); - if ( grep { $vp->version_lt($_->{dbh}, '5.5') } $src, $dst ) { + if ( grep { VersionParser->new($_->{dbh}) < '5.5' } $src, $dst ) { disconnect($src, $dst); die "--lock-and-rename requires MySQL 5.5 or later"; } @@ -8072,8 +8558,7 @@ sub lock_and_rename { # Exit status sub sync_one_table { my ( %args ) = @_; - my @required_args = qw(dsns plugins OptionParser DSNParser Quoter - VersionParser); + my @required_args = qw(dsns plugins OptionParser DSNParser Quoter); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } @@ -8140,7 +8625,6 @@ sub sync_one_table { # OptionParser - object # DSNParser - object # Quoter - object -# VersionParser - object # TableChecksum - object # MasterSlave - object # @@ -8152,7 +8636,7 @@ sub sync_one_table { sub sync_via_replication { my ( %args ) = @_; my @required_args = qw(dsns plugins OptionParser DSNParser Quoter - VersionParser TableChecksum MasterSlave); + TableChecksum MasterSlave); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } @@ -8352,7 +8836,6 @@ sub sync_via_replication { # OptionParser - object # DSNParser - object # Quoter - object -# VersionParser - object # TableParser - object # MySQLDump - object # @@ -8889,8 +9372,7 @@ sub get_cxn { # instead, it should check if it's already set to STATEMENT. # This is becase starting with MySQL 5.1.29, changing the format # requires a SUPER user. - my $vp = new VersionParser(); - if ( $vp->version_ge($dbh, '5.1.5') ) { + if ( VersionParser->new($dbh) >= '5.1.29' ) { $sql = 'SELECT @@binlog_format'; PTDEBUG && _d($dbh, $sql); my ($original_binlog_format) = $dbh->selectrow_array($sql); @@ -8944,7 +9426,6 @@ sub get_cxn { # dst - Hashref with destination host information # DSNParser - object # Quoter - object -# VersionParser - object # TableParser - object # MySQLDump - object # TableSyncer - object @@ -8954,12 +9435,12 @@ sub get_cxn { # Table structure (from ) if ok to sync, else it dies. sub ok_to_sync { my ( %args ) = @_; - my @required_args = qw(src dst DSNParser Quoter VersionParser TableParser + my @required_args = qw(src dst DSNParser Quoter TableParser MySQLDump TableSyncer OptionParser); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } - my ($src, $dst, $dp, $q, $vp, $tp, $du, $syncer, $o) = @args{@required_args}; + my ($src, $dst, $dp, $q, $tp, $du, $syncer, $o) = @args{@required_args}; if ( !$src->{tbl_struct} ) { eval { @@ -9005,7 +9486,7 @@ sub ok_to_sync { if ( $o->get('check-triggers') ) { PTDEBUG && _d('Checking for triggers'); if ( !defined $dst->{supports_triggers} ) { - $dst->{supports_triggers} = $vp->version_ge($dst->{dbh}, '5.0.2'); + $dst->{supports_triggers} = VersionParser->new($dst->{dbh}) >= '5.0.2'; } if ( $dst->{supports_triggers} && $du->get_triggers($dst->{dbh}, $q, $dst->{db}, $dst->{tbl}) ) { diff --git a/bin/pt-upgrade b/bin/pt-upgrade index 908d4495..b1cb2986 100755 --- a/bin/pt-upgrade +++ b/bin/pt-upgrade @@ -673,7 +673,7 @@ sub get_keys { my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; $type = $type || $special || 'BTREE'; - if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000' + if ( $opts->{mysql_version} && $opts->{mysql_version} lt '4.1' && $engine =~ m/HEAP|MEMORY/i ) { $type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP @@ -1960,6 +1960,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # Transformers package # This package is a copy without comments from the original. The original @@ -6176,7 +6626,7 @@ our %ALGOS = ( sub new { my ( $class, %args ) = @_; - foreach my $arg ( qw(Quoter VersionParser) ) { + foreach my $arg ( qw(Quoter) ) { die "I need a $arg argument" unless defined $args{$arg}; } my $self = { %args }; @@ -6232,21 +6682,22 @@ sub get_crc_type { sub best_algorithm { my ( $self, %args ) = @_; my ( $alg, $dbh ) = @args{ qw(algorithm dbh) }; - my $vp = $self->{VersionParser}; my @choices = sort { $ALGOS{$a}->{pref} <=> $ALGOS{$b}->{pref} } keys %ALGOS; die "Invalid checksum algorithm $alg" if $alg && !$ALGOS{$alg}; + my $version = VersionParser->new($dbh); + if ( $args{where} || $args{chunk} # CHECKSUM does whole table || $args{replicate} # CHECKSUM can't do INSERT.. SELECT - || !$vp->version_ge($dbh, '4.1.1')) # CHECKSUM doesn't exist + || $version < '4.1.1') # CHECKSUM doesn't exist { PTDEBUG && _d('Cannot use CHECKSUM algorithm'); @choices = grep { $_ ne 'CHECKSUM' } @choices; } - if ( !$vp->version_ge($dbh, '4.1.1') ) { + if ( $version < '4.1.1' ) { PTDEBUG && _d('Cannot use BIT_XOR algorithm because MySQL < 4.1.1'); @choices = grep { $_ ne 'BIT_XOR' } @choices; } @@ -6553,7 +7004,7 @@ $Data::Dumper::Quotekeys = 0; sub new { my ( $class, %args ) = @_; - my @required_args = qw(MasterSlave Quoter VersionParser TableChecksum Retry); + my @required_args = qw(MasterSlave Quoter TableChecksum Retry); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless defined $args{$arg}; } @@ -6606,7 +7057,6 @@ sub sync_table { $args{timeout_ok} ||= 0; my $q = $self->{Quoter}; - my $vp = $self->{VersionParser}; my ($plugin, %plugin_args) = $self->get_best_plugin(%args); die "No plugin can sync $src->{db}.$src->{tbl}" unless $plugin; @@ -6618,8 +7068,8 @@ sub sync_table { PTDEBUG && _d('CRC column:', $crc_col); my $index_hint; - my $hint = ($vp->version_ge($src->{dbh}, '4.0.9') - && $vp->version_ge($dst->{dbh}, '4.0.9') ? 'FORCE' : 'USE') + my $hint = ((VersionParser->new($src->{dbh}) >= '4.0.9' + && VersionParser->new($dst->{dbh}) >= '4.0.9') ? 'FORCE' : 'USE') . ' INDEX'; if ( $args{chunk_index} ) { PTDEBUG && _d('Using given chunk index for index hint'); @@ -8121,96 +8571,137 @@ sub _d { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -8248,6 +8739,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -10502,18 +10994,16 @@ sub main { # Make some common modules. # ######################################################################## my $q = new Quoter(); - my $vp = new VersionParser(); my $qp = new QueryParser(); my $qr = new QueryRewriter(); my $rr = new Retry(); my $tp = new TableParser(Quoter => $q); my $chunker = new TableChunker(Quoter => $q, TableParser => $tp ); my $nibbler = new TableNibbler(Quoter => $q, TableParser => $tp ); - my $checksum = new TableChecksum(Quoter => $q, VersionParser => $vp); + my $checksum = new TableChecksum(Quoter => $q); my $syncer = new TableSyncer( MasterSlave => 1, # I don't think we need this. Quoter => $q, - VersionParser => $vp, TableChecksum => $checksum, Retry => $rr, ); @@ -10524,7 +11014,6 @@ sub main { QueryRewriter => $qr, TableParser => $tp, Quoter => $q, - VersionParser => $vp, TableChunker => $chunker, TableNibbler => $nibbler, TableChecksum => $checksum, @@ -10567,7 +11056,7 @@ sub main { # SHOW WARNINGS requires MySQL 4.1. my $have_warnings = 1; foreach my $host ( @$hosts ) { - if ( !$vp->version_ge($host->{dbh}, '4.1.0') ) { + if ( VersionParser->new($host->{dbh}) < '4.1.0' ) { warn "Compare warnings DISABLED because host ", $host->{name}, " MySQL version is less than 4.1"; $have_warnings = 0; diff --git a/bin/pt-variable-advisor b/bin/pt-variable-advisor index de54ac08..270b6c28 100755 --- a/bin/pt-variable-advisor +++ b/bin/pt-variable-advisor @@ -1033,6 +1033,456 @@ if ( PTDEBUG ) { # End OptionParser package # ########################################################################### +# ########################################################################### +# Mo 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/Mo.pm +# t/lib/Mo.t +# See https://launchpad.net/percona-toolkit for more information. +# ########################################################################### +{ +BEGIN { +$INC{"Mo.pm"} = __FILE__; +package Mo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util (); + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) }, + Num => sub { defined $_[0] && &Scalar::Util::looks_like_number }, + Int => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && &Scalar::Util::blessed }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +our %metadata_for; +{ + package Mo::Object; + + sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my @args_to_delete; + while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + if ( my $I = $metadata_for{$class}{$attribute}{isa} ) { + ( (my $I_name), $I ) = @{$I}; + Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + @_ = %$args; + my $self = bless $args, $class; + + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE}; + } + exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs; + return $self; + } + + sub BUILDARGS { + shift; + my $ref; + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref") + unless ref($_[0]) eq ref({}); + $ref = {%{$_[0]}} # We want a new reference, always + } + else { + $ref = { @_ }; + } + return $ref; + } +} + +my %export_for; +sub Mo::import { + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my (%exports, %options); + + my (undef, @features) = @_; + my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) ); + for my $feature (grep { !$ignore{$_} } @features) { + { local $@; require "Mo/$feature.pm"; } + { + no strict 'refs'; + &{"Mo::${feature}::e"}( + $caller_pkg, + \%exports, + \%options, + \@_ + ); + } + } + + return if $exports{M}; + + %exports = ( + extends => sub { + for my $class ( map { "$_" } @_ ) { + $class =~ s{::|'}{/}g; + { local $@; eval { require "$class.pm" } } # or warn $@; + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); + }, + has => sub { + my $names = shift; + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $metadata_for{$caller}{$attribute} = (); + + if ( my $I = $args{isa} ) { + my $orig_I = $I; + my $type; + if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $I = _nested_constraints($attribute, $1, $2); + } + $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I]; + my $orig_method = $method; + $method = sub { + if ( $#_ ) { + Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]); + } + goto &$orig_method; + }; + } + + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless blessed($_[1]) && $_[1]->does($role) + } + goto &$original_method + }; + } + + if ( my $coercion = $args{coerce} ) { + $metadata_for{$caller}{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + $method = $options{$_}->($method, $attribute, @_) + for sort keys %options; + + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $metadata_for{$caller}{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg}; + } + } + }, + %exports, + ); + + $export_for{$caller} = [ keys %exports ]; + + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" ) + unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] }; +}; + +sub _check_type_constaints { + my ($attribute, $I, $I_name, $val) = @_; + ( ref($I) eq 'CODE' + ? $I->($val) + : (ref $val eq $I + || ($val && $val eq $I) + || (exists $TYPES{$I} && $TYPES{$I}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Mo::Dumper($val) : 'undef') ) +} + +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Mo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $inner_types = _nested_constraints($1, $2); + } + else { + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + return 1 if ! defined($value); + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +sub _set_package_isa { + my ($package, @new_isa) = @_; + + *{ _glob_for "${package}::ISA" } = [@new_isa]; +} + +sub _set_inherited_metadata { + my $class = shift; + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + for my $isa_class (reverse @$linearized_isa) { + %new_metadata = ( + %new_metadata, + %{ $metadata_for{$isa_class} || {} }, + ); + } + $metadata_for{$class} = \%new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +} +# ########################################################################### +# End Mo package +# ########################################################################### + # ########################################################################### # DSNParser package # This package is a copy without comments from the original. The original @@ -1405,96 +1855,137 @@ sub _d { { package VersionParser; -use strict; -use warnings FATAL => 'all'; +use Mo; +use Scalar::Util qw(blessed); use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -sub new { - my ( $class ) = @_; - bless {}, $class; -} +use overload ( + '""' => "version", + '<=>' => "cmp", + 'cmp' => "cmp", + fallback => 1, +); -sub parse { - my ( $self, $str ) = @_; - my @version_parts = $str =~ m/(\d+)/g; - @version_parts = map { $_ || 0 } @version_parts[0..2]; - my $result = sprintf('%03d%03d%03d', @version_parts); - PTDEBUG && _d($str, 'parses to', $result); - return $result; -} +our $VERSION = 0.01; -sub version_cmp { - my ($self, $dbh, $target, $cmp) = @_; - my $version = $self->version($dbh); - my $result; +has major => ( + is => 'ro', + isa => 'Int', + required => 1, +); - if ( $cmp eq 'ge' ) { - $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'gt' ) { - $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'eq' ) { - $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'ne' ) { - $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'lt' ) { - $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0; - } - elsif ( $cmp eq 'le' ) { - $result = $self->{$dbh} le $self->parse($target) ? 1 : 0; - } - else { - die "Asked for an unknown comparizon: $cmp" - } +has [qw( minor revision )] => ( + is => 'ro', + isa => 'Num', +); - PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result); - return $result; -} +has flavor => ( + is => 'ro', + isa => 'Str', + default => sub { 'Unknown' }, +); -sub version_ge { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ge'); -} +has innodb_version => ( + is => 'ro', + isa => 'Str', + default => sub { 'NO' }, +); -sub version_gt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'gt'); -} - -sub version_eq { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'eq'); -} - -sub version_ne { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'ne'); -} - -sub version_lt { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'lt'); -} - -sub version_le { - my ( $self, $dbh, $target ) = @_; - return $self->version_cmp($dbh, $target, 'le'); +sub series { + my $self = shift; + return $self->_join_version($self->major, $self->minor); } sub version { - my ( $self, $dbh ) = @_; - if ( !$self->{$dbh} ) { - $self->{$dbh} = $self->parse( - $dbh->selectrow_array('SELECT VERSION()')); - } - return $self->{$dbh}; + my $self = shift; + return $self->_join_version($self->major, $self->minor, $self->revision); } -sub innodb_version { +sub is_in { + my ($self, $target) = @_; + + return $self eq $target; +} + +sub _join_version { + my ($self, @parts) = @_; + + return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; +} +sub _split_version { + my ($self, $str) = @_; + my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; + return @version_parts[0..2]; +} + +sub normalized_version { + my ( $self ) = @_; + my @version_parts = map { $_ || 0 } $self->_split_version( $self->version ); + my $result = sprintf('%d%02d%02d', @version_parts); + PTDEBUG && _d($self->version, 'normalizes to', $result); + return $result; +} + +sub comment { + my ( $self, $cmd ) = @_; + my $v = $self->normalized_version(); + + return "/*!$v $cmd */" +} + +my @methods = qw(major minor revision); +sub cmp { + my ($left, $right) = @_; + my $right_obj = (blessed($right) && $right->isa(ref($left))) + ? $right + : ref($left)->new($right); + + my $retval = 0; + for my $m ( @methods ) { + last unless defined($left->$m) && defined($right_obj->$m); + $retval = $left->$m <=> $right_obj->$m; + last if $retval; + } + return $retval; +} + +sub BUILDARGS { + my $self = shift; + + if ( @_ == 1 ) { + my %args; + if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { + my $dbh = $_[0]; + my $query; + PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); + if ( eval { $query = $dbh->selectall_hashref(q) } ) { + @args{@methods} = $self->_split_version($query->{version}); + $args{flavor} = delete $query->{version_comment} + if $query->{version_comment}; + } + elsif ( eval { ($query) = $dbh->selectrow_array('SELECT VERSION()') } ) { + @args{@methods} = $self->_split_version($query); + } + else { + PTDEBUG && _d("Couldn't get the version from the dbh: $@"); + } + $args{innodb_version} = eval { $self->_innodb_version($dbh) }; + } + elsif ( !ref($_[0]) ) { + @args{@methods} = $self->_split_version($_[0]); + } + + for my $method (@methods) { + delete $args{$method} unless defined $args{$method}; + } + @_ = %args if %args; + } + + return $self->SUPER::BUILDARGS(@_); +} + +sub _innodb_version { my ( $self, $dbh ) = @_; return unless $dbh; my $innodb_version = "NO"; @@ -1532,6 +2023,7 @@ sub _d { print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; } +no Mo; 1; } # ########################################################################### @@ -2800,27 +3292,11 @@ sub get_rules { my ( %args ) = @_; my $mysql_version = $args{mysql_version}; return 0 unless $mysql_version; - my ($major, $minor, $patch) = $mysql_version =~ m/(\d{3})/g; - if ( $major eq '003' ) { - return $mysql_version lt '003023000' ? 1 : 0; # 3.23.x - } - elsif ( $major eq '004' ) { - return $mysql_version lt '004001020' ? 1 : 0; # 4.1.20 - } - elsif ( $major eq '005' ) { - if ( $minor eq '000' ) { - return $mysql_version lt '005000037' ? 1 : 0; # 5.0.37 - } - elsif ( $minor eq '001' ) { - return $mysql_version lt '005001030' ? 1 : 0; # 5.1.30 - } - else { - return 0; - } - } - else { - return 0; - } + return 1 if ($mysql_version eq '3' && $mysql_version lt '3.23') + || ($mysql_version eq '4' && $mysql_version lt '4.1.20') + || ($mysql_version eq '5.0' && $mysql_version lt '5.0.37') + || ($mysql_version eq '5.1' && $mysql_version lt '5.1.30'); + return 0; }, }, { @@ -2829,7 +3305,7 @@ sub get_rules { my ( %args ) = @_; my $mysql_version = $args{mysql_version}; return 0 unless $mysql_version; - return $mysql_version lt '005001000' ? 1 : 0; # 5.1.x + return $mysql_version lt '5.1' ? 1 : 0; # 5.1.x }, }, }; @@ -2956,13 +3432,11 @@ sub main { # ######################################################################### # Make common modules. # ######################################################################### - my $vp = new VersionParser(); my $trp = new TextResultSetParser(); my %common_modules = ( OptionParser => $o, DSNParser => $dp, TextResultSetParser => $trp, - VersionParser => $vp, ); # ########################################################################## @@ -3006,8 +3480,9 @@ sub main { %common_modules, ); - my $mysql_version = $vp->parse($vars->{version}); - my $innodb_version = $vp->innodb_version($dbh); + my $mysql_version = VersionParser->new($vars->{version}); + my $innodb_version = VersionParser->new($dbh)->innodb_version() + if $dbh; PTDEBUG && _d("MySQL version", $mysql_version, "InnoDB version", $innodb_version);