← Back to branch summary

~percona-toolkit-dev/percona-toolkit/fix-pt-heartbeat-dupe-key-bug-1004567

« back to all changes in this revision

Viewing changes to bin/pt-slave-find

  • Committer: Brian Fraser
  • Date: 2012-07-20 20:25:10 UTC
  • mfrom: (303.2.27 new-versionparser)
  • Revision ID: brian.fraser@percona.com-20120720202510-zoia5ndqchpcysec
Merged new-versionparser

Show diffs side-by-side

added added

removed removed

Lines of Context:
bin/pt-slave-find
1034
1034
# ###########################################################################
1035
1035
 
1036
1036
# ###########################################################################
 
1037
# Mo package
 
1038
# This package is a copy without comments from the original.  The original
 
1039
# with comments and its test file can be found in the Bazaar repository at,
 
1040
#   lib/Mo.pm
 
1041
#   t/lib/Mo.t
 
1042
# See https://launchpad.net/percona-toolkit for more information.
 
1043
# ###########################################################################
 
1044
{
 
1045
BEGIN {
 
1046
$INC{"Mo.pm"} = __FILE__;
 
1047
package Mo;
 
1048
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
 
1049
 
 
1050
{
 
1051
   no strict 'refs';
 
1052
   sub _glob_for {
 
1053
      return \*{shift()}
 
1054
   }
 
1055
 
 
1056
   sub _stash_for {
 
1057
      return \%{ shift() . "::" };
 
1058
   }
 
1059
}
 
1060
 
 
1061
use strict;
 
1062
use warnings qw( FATAL all );
 
1063
 
 
1064
use Carp ();
 
1065
use Scalar::Util ();
 
1066
 
 
1067
our %TYPES = (
 
1068
   Bool   => sub { !$_[0] || (defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == 1) },
 
1069
   Num    => sub { defined $_[0] && &Scalar::Util::looks_like_number },
 
1070
   Int    => sub { defined $_[0] && &Scalar::Util::looks_like_number && $_[0] == int $_[0] },
 
1071
   Str    => sub { defined $_[0] },
 
1072
   Object => sub { defined $_[0] && &Scalar::Util::blessed },
 
1073
   FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened },
 
1074
 
 
1075
   map {
 
1076
      my $type = /R/ ? $_ : uc $_;
 
1077
      $_ . "Ref" => sub { ref $_[0] eq $type }
 
1078
   } qw(Array Code Hash Regexp Glob Scalar)
 
1079
);
 
1080
 
 
1081
our %metadata_for;
 
1082
{
 
1083
   package Mo::Object;
 
1084
 
 
1085
   sub new {
 
1086
      my $class = shift;
 
1087
      my $args  = $class->BUILDARGS(@_);
 
1088
 
 
1089
      my @args_to_delete;
 
1090
      while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) {
 
1091
         next unless exists $meta->{init_arg};
 
1092
         my $init_arg = $meta->{init_arg};
 
1093
 
 
1094
         if ( defined $init_arg ) {
 
1095
            $args->{$attr} = delete $args->{$init_arg};
 
1096
         }
 
1097
         else {
 
1098
            push @args_to_delete, $attr;
 
1099
         }
 
1100
      }
 
1101
 
 
1102
      delete $args->{$_} for @args_to_delete;
 
1103
 
 
1104
      for my $attribute ( keys %$args ) {
 
1105
         if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) {
 
1106
            $args->{$attribute} = $coerce->($args->{$attribute});
 
1107
         }
 
1108
         if ( my $I = $metadata_for{$class}{$attribute}{isa} ) {
 
1109
            ( (my $I_name), $I ) = @{$I};
 
1110
            Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute});
 
1111
         }
 
1112
      }
 
1113
 
 
1114
      while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) {
 
1115
         next unless $meta->{required};
 
1116
         Carp::confess("Attribute ($attribute) is required for $class")
 
1117
            if ! exists $args->{$attribute}
 
1118
      }
 
1119
 
 
1120
      @_ = %$args;
 
1121
      my $self = bless $args, $class;
 
1122
 
 
1123
      my @build_subs;
 
1124
      my $linearized_isa = mro::get_linear_isa($class);
 
1125
 
 
1126
      for my $isa_class ( @$linearized_isa ) {
 
1127
         unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE};
 
1128
      }
 
1129
      exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs;
 
1130
      return $self;
 
1131
   }
 
1132
 
 
1133
   sub BUILDARGS {
 
1134
      shift;
 
1135
      my $ref;
 
1136
      if ( @_ == 1 && ref($_[0]) ) {
 
1137
         Carp::confess("Single parameters to new() must be a HASH ref")
 
1138
            unless ref($_[0]) eq ref({});
 
1139
         $ref = {%{$_[0]}} # We want a new reference, always
 
1140
      }
 
1141
      else {
 
1142
         $ref = { @_ };
 
1143
      }
 
1144
      return $ref;
 
1145
   }
 
1146
}
 
1147
 
 
1148
my %export_for;
 
1149
sub Mo::import {
 
1150
    warnings->import(qw(FATAL all));
 
1151
    strict->import();
 
1152
    
 
1153
    my $caller     = scalar caller(); # Caller's package
 
1154
    my $caller_pkg = $caller . "::"; # Caller's package with :: at the end
 
1155
    my (%exports, %options);
 
1156
 
 
1157
    my (undef, @features) = @_;
 
1158
    my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) );
 
1159
    for my $feature (grep { !$ignore{$_} } @features) {
 
1160
      { local $@; require "Mo/$feature.pm"; }
 
1161
      {
 
1162
         no strict 'refs';
 
1163
         &{"Mo::${feature}::e"}(
 
1164
                  $caller_pkg,
 
1165
                  \%exports,
 
1166
                  \%options,
 
1167
                  \@_
 
1168
            );
 
1169
      }
 
1170
    }
 
1171
 
 
1172
    return if $exports{M}; 
 
1173
 
 
1174
    %exports = (
 
1175
        extends => sub {
 
1176
            for my $class ( map { "$_" } @_ ) {
 
1177
               $class =~ s{::|'}{/}g;
 
1178
               { local $@; eval { require "$class.pm" } } # or warn $@;
 
1179
            }
 
1180
            _set_package_isa($caller, @_);
 
1181
            _set_inherited_metadata($caller);
 
1182
        },
 
1183
        has => sub {
 
1184
            my $names = shift;
 
1185
            for my $attribute ( ref $names ? @$names : $names ) {
 
1186
               my %args   = @_;
 
1187
               my $method = ($args{is} || '') eq 'ro'
 
1188
                  ? sub {
 
1189
                     Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}")
 
1190
                        if $#_;
 
1191
                     return $_[0]{$attribute};
 
1192
                  }
 
1193
                  : sub {
 
1194
                     return $#_
 
1195
                           ? $_[0]{$attribute} = $_[1]
 
1196
                           : $_[0]{$attribute};
 
1197
                  };
 
1198
 
 
1199
               $metadata_for{$caller}{$attribute} = ();
 
1200
 
 
1201
               if ( my $I = $args{isa} ) {
 
1202
                  my $orig_I = $I;
 
1203
                  my $type;
 
1204
                  if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
 
1205
                     $I = _nested_constraints($attribute, $1, $2);
 
1206
                  }
 
1207
                  $metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I];
 
1208
                  my $orig_method = $method;
 
1209
                  $method = sub {
 
1210
                     if ( $#_ ) {
 
1211
                        Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]);
 
1212
                     }
 
1213
                     goto &$orig_method;
 
1214
                  };
 
1215
               }
 
1216
 
 
1217
               if ( my $builder = $args{builder} ) {
 
1218
                  my $original_method = $method;
 
1219
                  $method = sub {
 
1220
                        $#_
 
1221
                           ? goto &$original_method
 
1222
                           : ! exists $_[0]{$attribute}
 
1223
                              ? $_[0]{$attribute} = $_[0]->$builder
 
1224
                              : goto &$original_method
 
1225
                  };
 
1226
               }
 
1227
 
 
1228
               if ( my $code = $args{default} ) {
 
1229
                  Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
 
1230
                        unless ref($code) eq 'CODE';
 
1231
                  my $original_method = $method;
 
1232
                  $method = sub {
 
1233
                        $#_
 
1234
                           ? goto &$original_method
 
1235
                           : ! exists $_[0]{$attribute}
 
1236
                              ? $_[0]{$attribute} = $_[0]->$code
 
1237
                              : goto &$original_method
 
1238
                  };
 
1239
               }
 
1240
 
 
1241
               if ( my $role = $args{does} ) {
 
1242
                  my $original_method = $method;
 
1243
                  $method = sub {
 
1244
                     if ( $#_ ) {
 
1245
                        Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
 
1246
                           unless blessed($_[1]) && $_[1]->does($role)
 
1247
                     }
 
1248
                     goto &$original_method
 
1249
                  };
 
1250
               }
 
1251
 
 
1252
               if ( my $coercion = $args{coerce} ) {
 
1253
                  $metadata_for{$caller}{$attribute}{coerce} = $coercion;
 
1254
                  my $original_method = $method;
 
1255
                  $method = sub {
 
1256
                     if ( $#_ ) {
 
1257
                        return $original_method->($_[0], $coercion->($_[1]))
 
1258
                     }
 
1259
                     goto &$original_method;
 
1260
                  }
 
1261
               }
 
1262
 
 
1263
               $method = $options{$_}->($method, $attribute, @_)
 
1264
                  for sort keys %options;
 
1265
 
 
1266
               *{ _glob_for "${caller}::$attribute" } = $method;
 
1267
 
 
1268
               if ( $args{required} ) {
 
1269
                  $metadata_for{$caller}{$attribute}{required} = 1;
 
1270
               }
 
1271
 
 
1272
               if ($args{clearer}) {
 
1273
                  *{ _glob_for "${caller}::$args{clearer}" }
 
1274
                     = sub { delete shift->{$attribute} }
 
1275
               }
 
1276
 
 
1277
               if ($args{predicate}) {
 
1278
                  *{ _glob_for "${caller}::$args{predicate}" }
 
1279
                     = sub { exists shift->{$attribute} }
 
1280
               }
 
1281
 
 
1282
               if ($args{handles}) {
 
1283
                  _has_handles($caller, $attribute, \%args);
 
1284
               }
 
1285
 
 
1286
               if (exists $args{init_arg}) {
 
1287
                  $metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg};
 
1288
               }
 
1289
            }
 
1290
        },
 
1291
        %exports,
 
1292
    );
 
1293
 
 
1294
    $export_for{$caller} = [ keys %exports ];
 
1295
 
 
1296
    for my $keyword ( keys %exports ) {
 
1297
      *{ _glob_for "${caller}::$keyword" } = $exports{$keyword}
 
1298
    }
 
1299
    *{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" )
 
1300
      unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] };
 
1301
};
 
1302
 
 
1303
sub _check_type_constaints {
 
1304
   my ($attribute, $I, $I_name, $val) = @_;
 
1305
   ( ref($I) eq 'CODE'
 
1306
      ? $I->($val)
 
1307
      : (ref $val eq $I
 
1308
         || ($val && $val eq $I)
 
1309
         || (exists $TYPES{$I} && $TYPES{$I}->($val)))
 
1310
   )
 
1311
   || Carp::confess(
 
1312
         qq<Attribute ($attribute) does not pass the type constraint because: >
 
1313
      . qq<Validation failed for '$I_name' with value >
 
1314
      . (defined $val ? Mo::Dumper($val) : 'undef') )
 
1315
}
 
1316
 
 
1317
sub _has_handles {
 
1318
   my ($caller, $attribute, $args) = @_;
 
1319
   my $handles = $args->{handles};
 
1320
 
 
1321
   my $ref = ref $handles;
 
1322
   my $kv;
 
1323
   if ( $ref eq ref [] ) {
 
1324
         $kv = { map { $_,$_ } @{$handles} };
 
1325
   }
 
1326
   elsif ( $ref eq ref {} ) {
 
1327
         $kv = $handles;
 
1328
   }
 
1329
   elsif ( $ref eq ref qr// ) {
 
1330
         Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
 
1331
            unless $args->{isa};
 
1332
         my $target_class = $args->{isa};
 
1333
         $kv = {
 
1334
            map   { $_, $_     }
 
1335
            grep  { $_ =~ $handles }
 
1336
            grep  { !exists $Mo::Object::{$_} && $target_class->can($_) }
 
1337
            grep  { $_ ne 'has' && $_ ne 'extends' }
 
1338
            keys %{ _stash_for $target_class }
 
1339
         };
 
1340
   }
 
1341
   else {
 
1342
         Carp::confess("handles for $ref not yet implemented");
 
1343
   }
 
1344
 
 
1345
   while ( my ($method, $target) = each %{$kv} ) {
 
1346
         my $name = _glob_for "${caller}::$method";
 
1347
         Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
 
1348
            if defined &$name;
 
1349
 
 
1350
         my ($target, @curried_args) = ref($target) ? @$target : $target;
 
1351
         *$name = sub {
 
1352
            my $self        = shift;
 
1353
            my $delegate_to = $self->$attribute();
 
1354
            my $error = "Cannot delegate $method to $target because the value of $attribute";
 
1355
            Carp::confess("$error is not defined") unless $delegate_to;
 
1356
            Carp::confess("$error is not an object (got '$delegate_to')")
 
1357
               unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
 
1358
            return $delegate_to->$target(@curried_args, @_);
 
1359
         }
 
1360
   }
 
1361
}
 
1362
 
 
1363
sub _nested_constraints {
 
1364
   my ($attribute, $aggregate_type, $type) = @_;
 
1365
 
 
1366
   my $inner_types;
 
1367
   if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
 
1368
      $inner_types = _nested_constraints($1, $2);
 
1369
   }
 
1370
   else {
 
1371
      $inner_types = $TYPES{$type};
 
1372
   }
 
1373
 
 
1374
   if ( $aggregate_type eq 'ArrayRef' ) {
 
1375
      return sub {
 
1376
         my ($val) = @_;
 
1377
         return unless ref($val) eq ref([]);
 
1378
 
 
1379
         if ($inner_types) {
 
1380
            for my $value ( @{$val} ) {
 
1381
               return unless $inner_types->($value) 
 
1382
            }
 
1383
         }
 
1384
         else {
 
1385
            for my $value ( @{$val} ) {
 
1386
               return unless $value && ($value eq $type
 
1387
                        || (Scalar::Util::blessed($value) && $value->isa($type)));
 
1388
            }
 
1389
         }
 
1390
         return 1;
 
1391
      };
 
1392
   }
 
1393
   elsif ( $aggregate_type eq 'Maybe' ) {
 
1394
      return sub {
 
1395
         my ($value) = @_;
 
1396
         return 1 if ! defined($value);
 
1397
         if ($inner_types) {
 
1398
            return unless $inner_types->($value) 
 
1399
         }
 
1400
         else {
 
1401
            return unless $value eq $type
 
1402
                        || (Scalar::Util::blessed($value) && $value->isa($type));
 
1403
         }
 
1404
         return 1;
 
1405
      }
 
1406
   }
 
1407
   else {
 
1408
      Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
 
1409
   }
 
1410
}
 
1411
 
 
1412
sub _set_package_isa {
 
1413
   my ($package, @new_isa) = @_;
 
1414
 
 
1415
   *{ _glob_for "${package}::ISA" } = [@new_isa];
 
1416
}
 
1417
 
 
1418
sub _set_inherited_metadata {
 
1419
   my $class = shift;
 
1420
   my $linearized_isa = mro::get_linear_isa($class);
 
1421
   my %new_metadata;
 
1422
 
 
1423
   for my $isa_class (reverse @$linearized_isa) {
 
1424
      %new_metadata = (
 
1425
         %new_metadata,
 
1426
         %{ $metadata_for{$isa_class} || {} },
 
1427
      );
 
1428
   }
 
1429
   $metadata_for{$class} = \%new_metadata;
 
1430
}
 
1431
 
 
1432
sub unimport {
 
1433
   my $caller = scalar caller();
 
1434
   my $stash  = _stash_for( $caller );
 
1435
 
 
1436
   delete $stash->{$_} for @{$export_for{$caller}};
 
1437
}
 
1438
 
 
1439
sub Dumper {
 
1440
   require Data::Dumper;
 
1441
   local $Data::Dumper::Indent    = 0;
 
1442
   local $Data::Dumper::Sortkeys  = 0;
 
1443
   local $Data::Dumper::Quotekeys = 0;
 
1444
   local $Data::Dumper::Terse     = 1;
 
1445
 
 
1446
   Data::Dumper::Dumper(@_)
 
1447
}
 
1448
 
 
1449
BEGIN {
 
1450
   if ($] >= 5.010) {
 
1451
      { local $@; require mro; }
 
1452
   }
 
1453
   else {
 
1454
      local $@;
 
1455
      eval {
 
1456
         require MRO::Compat;
 
1457
      } or do {
 
1458
         *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
 
1459
            no strict 'refs';
 
1460
 
 
1461
            my $classname = shift;
 
1462
 
 
1463
            my @lin = ($classname);
 
1464
            my %stored;
 
1465
            foreach my $parent (@{"$classname\::ISA"}) {
 
1466
               my $plin = mro::get_linear_isa_dfs($parent);
 
1467
               foreach (@$plin) {
 
1468
                     next if exists $stored{$_};
 
1469
                     push(@lin, $_);
 
1470
                     $stored{$_} = 1;
 
1471
               }
 
1472
            }
 
1473
            return \@lin;
 
1474
         };
 
1475
      }
 
1476
   }
 
1477
}
 
1478
 
 
1479
}
 
1480
1;
 
1481
}
 
1482
# ###########################################################################
 
1483
# End Mo package
 
1484
# ###########################################################################
 
1485
 
 
1486
# ###########################################################################
1037
1487
# DSNParser package
1038
1488
# This package is a copy without comments from the original.  The original
1039
1489
# with comments and its test file can be found in the Bazaar repository at,
1618
2068
 
1619
2069
   my $show = "SHOW GRANTS FOR ";
1620
2070
   my $user = 'CURRENT_USER()';
1621
 
   my $vp   = $self->{VersionParser};
1622
 
   if ( $vp && !$vp->version_ge($dbh, '4.1.2') ) {
1623
 
      $user = $dbh->selectrow_arrayref('SELECT USER()')->[0];
1624
 
      $user =~ s/([^@]+)@(.+)/'$1'\@'$2'/;
1625
 
   }
1626
2071
   my $sql = $show . $user;
1627
2072
   PTDEBUG && _d($dbh, $sql);
1628
2073
 
2313
2758
{
2314
2759
package VersionParser;
2315
2760
 
2316
 
use strict;
2317
 
use warnings FATAL => 'all';
 
2761
use Mo;
 
2762
use Scalar::Util qw(blessed);
2318
2763
use English qw(-no_match_vars);
2319
2764
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2320
2765
 
2321
 
sub new {
2322
 
   my ( $class ) = @_;
2323
 
   bless {}, $class;
2324
 
}
2325
 
 
2326
 
sub parse {
2327
 
   my ( $self, $str ) = @_;
2328
 
   my @version_parts = $str =~ m/(\d+)/g;
2329
 
   @version_parts = map { $_ || 0 } @version_parts[0..2];
2330
 
   my $result = sprintf('%03d%03d%03d', @version_parts);
2331
 
   PTDEBUG && _d($str, 'parses to', $result);
2332
 
   return $result;
2333
 
}
2334
 
 
2335
 
sub version_cmp {
2336
 
   my ($self, $dbh, $target, $cmp) = @_;
2337
 
   my $version = $self->version($dbh);
2338
 
   my $result;
2339
 
 
2340
 
   if ( $cmp eq 'ge' ) {
2341
 
      $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0;
2342
 
   }
2343
 
   elsif ( $cmp eq 'gt' ) {
2344
 
      $result = $self->{$dbh} gt $self->parse($target) ? 1 : 0;
2345
 
   }
2346
 
   elsif ( $cmp eq 'eq' ) {
2347
 
      $result = $self->{$dbh} eq $self->parse($target) ? 1 : 0;
2348
 
   }
2349
 
   elsif ( $cmp eq 'ne' ) {
2350
 
      $result = $self->{$dbh} ne $self->parse($target) ? 1 : 0;
2351
 
   }
2352
 
   elsif ( $cmp eq 'lt' ) {
2353
 
      $result = $self->{$dbh} lt $self->parse($target) ? 1 : 0;
2354
 
   }
2355
 
   elsif ( $cmp eq 'le' ) {
2356
 
      $result = $self->{$dbh} le $self->parse($target) ? 1 : 0;
2357
 
   }
2358
 
   else {
2359
 
      die "Asked for an unknown comparizon: $cmp"
2360
 
   }
2361
 
 
2362
 
   PTDEBUG && _d($self->{$dbh}, $cmp, $target, ':', $result);
2363
 
   return $result;
2364
 
}
2365
 
 
2366
 
sub version_ge {
2367
 
   my ( $self, $dbh, $target ) = @_;
2368
 
   return $self->version_cmp($dbh, $target, 'ge');
2369
 
}
2370
 
 
2371
 
sub version_gt {
2372
 
   my ( $self, $dbh, $target ) = @_;
2373
 
   return $self->version_cmp($dbh, $target, 'gt');
2374
 
}
2375
 
 
2376
 
sub version_eq {
2377
 
   my ( $self, $dbh, $target ) = @_;
2378
 
   return $self->version_cmp($dbh, $target, 'eq');
2379
 
}
2380
 
 
2381
 
sub version_ne {
2382
 
   my ( $self, $dbh, $target ) = @_;
2383
 
   return $self->version_cmp($dbh, $target, 'ne');
2384
 
}
2385
 
 
2386
 
sub version_lt {
2387
 
   my ( $self, $dbh, $target ) = @_;
2388
 
   return $self->version_cmp($dbh, $target, 'lt');
2389
 
}
2390
 
 
2391
 
sub version_le {
2392
 
   my ( $self, $dbh, $target ) = @_;
2393
 
   return $self->version_cmp($dbh, $target, 'le');
 
2766
use overload (
 
2767
   '""'     => "version",
 
2768
   '<=>'    => "cmp",
 
2769
   'cmp'    => "cmp",
 
2770
   fallback => 1,
 
2771
);
 
2772
 
 
2773
use Carp ();
 
2774
 
 
2775
our $VERSION = 0.01;
 
2776
 
 
2777
has major => (
 
2778
    is       => 'ro',
 
2779
    isa      => 'Int',
 
2780
    required => 1,
 
2781
);
 
2782
 
 
2783
has [qw( minor revision )] => (
 
2784
    is  => 'ro',
 
2785
    isa => 'Num',
 
2786
);
 
2787
 
 
2788
has flavor => (
 
2789
    is      => 'ro',
 
2790
    isa     => 'Str',
 
2791
    default => sub { 'Unknown' },
 
2792
);
 
2793
 
 
2794
has innodb_version => (
 
2795
    is      => 'ro',
 
2796
    isa     => 'Str',
 
2797
    default => sub { 'NO' },
 
2798
);
 
2799
 
 
2800
sub series {
 
2801
   my $self = shift;
 
2802
   return $self->_join_version($self->major, $self->minor);
2394
2803
}
2395
2804
 
2396
2805
sub version {
2397
 
   my ( $self, $dbh ) = @_;
2398
 
   if ( !$self->{$dbh} ) {
2399
 
      $self->{$dbh} = $self->parse(
2400
 
         $dbh->selectrow_array('SELECT VERSION()'));
2401
 
   }
2402
 
   return $self->{$dbh};
2403
 
}
2404
 
 
2405
 
sub innodb_version {
 
2806
   my $self = shift;
 
2807
   return $self->_join_version($self->major, $self->minor, $self->revision);
 
2808
}
 
2809
 
 
2810
sub is_in {
 
2811
   my ($self, $target) = @_;
 
2812
 
 
2813
   return $self eq $target;
 
2814
}
 
2815
 
 
2816
sub _join_version {
 
2817
    my ($self, @parts) = @_;
 
2818
 
 
2819
    return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts;
 
2820
}
 
2821
sub _split_version {
 
2822
   my ($self, $str) = @_;
 
2823
   my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g;
 
2824
   return @version_parts[0..2];
 
2825
}
 
2826
 
 
2827
sub normalized_version {
 
2828
   my ( $self ) = @_;
 
2829
   my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major,
 
2830
                                                      $self->minor,
 
2831
                                                      $self->revision);
 
2832
   PTDEBUG && _d($self->version, 'normalizes to', $result);
 
2833
   return $result;
 
2834
}
 
2835
 
 
2836
sub comment {
 
2837
   my ( $self, $cmd ) = @_;
 
2838
   my $v = $self->normalized_version();
 
2839
 
 
2840
   return "/*!$v $cmd */"
 
2841
}
 
2842
 
 
2843
my @methods = qw(major minor revision);
 
2844
sub cmp {
 
2845
   my ($left, $right) = @_;
 
2846
   my $right_obj = (blessed($right) && $right->isa(ref($left)))
 
2847
                   ? $right
 
2848
                   : ref($left)->new($right);
 
2849
 
 
2850
   my $retval = 0;
 
2851
   for my $m ( @methods ) {
 
2852
      last unless defined($left->$m) && defined($right_obj->$m);
 
2853
      $retval = $left->$m <=> $right_obj->$m;
 
2854
      last if $retval;
 
2855
   }
 
2856
   return $retval;
 
2857
}
 
2858
 
 
2859
sub BUILDARGS {
 
2860
   my $self = shift;
 
2861
 
 
2862
   if ( @_ == 1 ) {
 
2863
      my %args;
 
2864
      if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) {
 
2865
         PTDEBUG && _d("VersionParser got a dbh, trying to get the version");
 
2866
         my $dbh = $_[0];
 
2867
         local $dbh->{FetchHashKeyName} = 'NAME_lc';
 
2868
         my $query = eval {
 
2869
            $dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} })
 
2870
         };
 
2871
         if ( $query ) {
 
2872
            $query = { map { $_->{variable_name} => $_->{value} } @$query };
 
2873
            @args{@methods} = $self->_split_version($query->{version});
 
2874
            $args{flavor} = delete $query->{version_comment}
 
2875
                  if $query->{version_comment};
 
2876
         }
 
2877
         elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) {
 
2878
            @args{@methods} = $self->_split_version($query);
 
2879
         }
 
2880
         else {
 
2881
            Carp::confess("Couldn't get the version from the dbh while "
 
2882
                        . "creating a VersionParser object: $@");
 
2883
         }
 
2884
         $args{innodb_version} = eval { $self->_innodb_version($dbh) };
 
2885
      }
 
2886
      elsif ( !ref($_[0]) ) {
 
2887
         @args{@methods} = $self->_split_version($_[0]);
 
2888
      }
 
2889
 
 
2890
      for my $method (@methods) {
 
2891
         delete $args{$method} unless defined $args{$method};
 
2892
      }
 
2893
      @_ = %args if %args;
 
2894
   }
 
2895
 
 
2896
   return $self->SUPER::BUILDARGS(@_);
 
2897
}
 
2898
 
 
2899
sub _innodb_version {
2406
2900
   my ( $self, $dbh ) = @_;
2407
2901
   return unless $dbh;
2408
2902
   my $innodb_version = "NO";
2440
2934
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2441
2935
}
2442
2936
 
 
2937
no Mo;
2443
2938
1;
2444
2939
}
2445
2940
# ###########################################################################
2860
3355
 
2861
3356
   # Despite the name, recursing to slaves actually begins at the specified
2862
3357
   # server, so the named server may also be included.
2863
 
   my $vp = new VersionParser();
2864
 
   my $ms = new MasterSlave(VersionParser => $vp);
 
3358
   my $ms = new MasterSlave();
2865
3359
   $ms->recurse_to_slaves(
2866
3360
      {  dbh        => $dbh,
2867
3361
         dsn        => $master_dsn,
2898
3392
      node          => $root,
2899
3393
      print_node    => $print_node,
2900
3394
      MasterSlave   => $ms,
2901
 
      VersionParser => $vp,
2902
3395
   );
2903
3396
 
2904
3397
   return 0;
2961
3454
 
2962
3455
sub print_node_summary {
2963
3456
   my ( %args ) = @_;
2964
 
   my ($ms, $vp, $node, $level)
2965
 
      = @args{qw(MasterSlave VersionParser node level)};
 
3457
   my ($ms, $node, $level)
 
3458
      = @args{qw(MasterSlave node level)};
2966
3459
   die "I need a node" unless $node;
2967
3460
   $level ||= 0;
2968
3461
 
3033
3526
      . ", offset "  . ($vars->{auto_increment_offset}->{value}   || '')
3034
3527
   ];
3035
3528
 
3036
 
   my $innodb_version = $vp->innodb_version($dbh);
 
3529
   my $innodb_version = VersionParser->new($dbh)->innodb_version();
3037
3530
   push @lines, ['InnoDB version', $innodb_version];
3038
3531
 
3039
3532
   my $line_fmt = "$indent%-15s %s";