1#!/usr/bin/env perl 2 3# This program is part of Percona Toolkit: http://www.percona.com/software/ 4# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal 5# notices and disclaimers. 6 7use strict; 8use warnings FATAL => 'all'; 9 10# This tool is "fat-packed": most of its dependent modules are embedded 11# in this file. Setting %INC to this file for each module makes Perl aware 12# of this so it will not try to load the module from @INC. See the tool's 13# documentation for a full list of dependencies. 14BEGIN { 15 $INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw( 16 Percona::Toolkit 17 Lmo::Utils 18 Lmo::Meta 19 Lmo::Object 20 Lmo::Types 21 Lmo 22 OptionParser 23 TableParser 24 DSNParser 25 VersionParser 26 Quoter 27 TableNibbler 28 Daemon 29 MasterSlave 30 FlowControlWaiter 31 Cxn 32 HTTP::Micro 33 VersionCheck 34 )); 35} 36 37# ########################################################################### 38# Percona::Toolkit package 39# This package is a copy without comments from the original. The original 40# with comments and its test file can be found in the Bazaar repository at, 41# lib/Percona/Toolkit.pm 42# t/lib/Percona/Toolkit.t 43# See https://launchpad.net/percona-toolkit for more information. 44# ########################################################################### 45{ 46package Percona::Toolkit; 47 48our $VERSION = '3.3.0'; 49 50use strict; 51use warnings FATAL => 'all'; 52use English qw(-no_match_vars); 53use constant PTDEBUG => $ENV{PTDEBUG} || 0; 54 55use Carp qw(carp cluck); 56use Data::Dumper qw(); 57 58require Exporter; 59our @ISA = qw(Exporter); 60our @EXPORT_OK = qw( 61 have_required_args 62 Dumper 63 _d 64); 65 66sub have_required_args { 67 my ($args, @required_args) = @_; 68 my $have_required_args = 1; 69 foreach my $arg ( @required_args ) { 70 if ( !defined $args->{$arg} ) { 71 $have_required_args = 0; 72 carp "Argument $arg is not defined"; 73 } 74 } 75 cluck unless $have_required_args; # print backtrace 76 return $have_required_args; 77} 78 79sub Dumper { 80 local $Data::Dumper::Indent = 1; 81 local $Data::Dumper::Sortkeys = 1; 82 local $Data::Dumper::Quotekeys = 0; 83 Data::Dumper::Dumper(@_); 84} 85 86sub _d { 87 my ($package, undef, $line) = caller 0; 88 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 89 map { defined $_ ? $_ : 'undef' } 90 @_; 91 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 92} 93 941; 95} 96# ########################################################################### 97# End Percona::Toolkit package 98# ########################################################################### 99 100# ########################################################################### 101# Lmo::Utils package 102# This package is a copy without comments from the original. The original 103# with comments and its test file can be found in the Bazaar repository at, 104# lib/Lmo/Utils.pm 105# t/lib/Lmo/Utils.t 106# See https://launchpad.net/percona-toolkit for more information. 107# ########################################################################### 108{ 109package Lmo::Utils; 110 111use strict; 112use warnings qw( FATAL all ); 113require Exporter; 114our (@ISA, @EXPORT, @EXPORT_OK); 115 116BEGIN { 117 @ISA = qw(Exporter); 118 @EXPORT = @EXPORT_OK = qw( 119 _install_coderef 120 _unimport_coderefs 121 _glob_for 122 _stash_for 123 ); 124} 125 126{ 127 no strict 'refs'; 128 sub _glob_for { 129 return \*{shift()} 130 } 131 132 sub _stash_for { 133 return \%{ shift() . "::" }; 134 } 135} 136 137sub _install_coderef { 138 my ($to, $code) = @_; 139 140 return *{ _glob_for $to } = $code; 141} 142 143sub _unimport_coderefs { 144 my ($target, @names) = @_; 145 return unless @names; 146 my $stash = _stash_for($target); 147 foreach my $name (@names) { 148 if ($stash->{$name} and defined(&{$stash->{$name}})) { 149 delete $stash->{$name}; 150 } 151 } 152} 153 1541; 155} 156# ########################################################################### 157# End Lmo::Utils package 158# ########################################################################### 159 160# ########################################################################### 161# Lmo::Meta package 162# This package is a copy without comments from the original. The original 163# with comments and its test file can be found in the Bazaar repository at, 164# lib/Lmo/Meta.pm 165# t/lib/Lmo/Meta.t 166# See https://launchpad.net/percona-toolkit for more information. 167# ########################################################################### 168{ 169package Lmo::Meta; 170use strict; 171use warnings qw( FATAL all ); 172 173my %metadata_for; 174 175sub new { 176 my $class = shift; 177 return bless { @_ }, $class 178} 179 180sub metadata_for { 181 my $self = shift; 182 my ($class) = @_; 183 184 return $metadata_for{$class} ||= {}; 185} 186 187sub class { shift->{class} } 188 189sub attributes { 190 my $self = shift; 191 return keys %{$self->metadata_for($self->class)} 192} 193 194sub attributes_for_new { 195 my $self = shift; 196 my @attributes; 197 198 my $class_metadata = $self->metadata_for($self->class); 199 while ( my ($attr, $meta) = each %$class_metadata ) { 200 if ( exists $meta->{init_arg} ) { 201 push @attributes, $meta->{init_arg} 202 if defined $meta->{init_arg}; 203 } 204 else { 205 push @attributes, $attr; 206 } 207 } 208 return @attributes; 209} 210 2111; 212} 213# ########################################################################### 214# End Lmo::Meta package 215# ########################################################################### 216 217# ########################################################################### 218# Lmo::Object package 219# This package is a copy without comments from the original. The original 220# with comments and its test file can be found in the Bazaar repository at, 221# lib/Lmo/Object.pm 222# t/lib/Lmo/Object.t 223# See https://launchpad.net/percona-toolkit for more information. 224# ########################################################################### 225{ 226package Lmo::Object; 227 228use strict; 229use warnings qw( FATAL all ); 230 231use Carp (); 232use Scalar::Util qw(blessed); 233 234use Lmo::Meta; 235use Lmo::Utils qw(_glob_for); 236 237sub new { 238 my $class = shift; 239 my $args = $class->BUILDARGS(@_); 240 241 my $class_metadata = Lmo::Meta->metadata_for($class); 242 243 my @args_to_delete; 244 while ( my ($attr, $meta) = each %$class_metadata ) { 245 next unless exists $meta->{init_arg}; 246 my $init_arg = $meta->{init_arg}; 247 248 if ( defined $init_arg ) { 249 $args->{$attr} = delete $args->{$init_arg}; 250 } 251 else { 252 push @args_to_delete, $attr; 253 } 254 } 255 256 delete $args->{$_} for @args_to_delete; 257 258 for my $attribute ( keys %$args ) { 259 if ( my $coerce = $class_metadata->{$attribute}{coerce} ) { 260 $args->{$attribute} = $coerce->($args->{$attribute}); 261 } 262 if ( my $isa_check = $class_metadata->{$attribute}{isa} ) { 263 my ($check_name, $check_sub) = @$isa_check; 264 $check_sub->($args->{$attribute}); 265 } 266 } 267 268 while ( my ($attribute, $meta) = each %$class_metadata ) { 269 next unless $meta->{required}; 270 Carp::confess("Attribute ($attribute) is required for $class") 271 if ! exists $args->{$attribute} 272 } 273 274 my $self = bless $args, $class; 275 276 my @build_subs; 277 my $linearized_isa = mro::get_linear_isa($class); 278 279 for my $isa_class ( @$linearized_isa ) { 280 unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE}; 281 } 282 my @args = %$args; 283 for my $sub (grep { defined($_) && exists &$_ } @build_subs) { 284 $sub->( $self, @args); 285 } 286 return $self; 287} 288 289sub BUILDARGS { 290 shift; # No need for the classname 291 if ( @_ == 1 && ref($_[0]) ) { 292 Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]") 293 unless ref($_[0]) eq ref({}); 294 return {%{$_[0]}} # We want a new reference, always 295 } 296 else { 297 return { @_ }; 298 } 299} 300 301sub meta { 302 my $class = shift; 303 $class = Scalar::Util::blessed($class) || $class; 304 return Lmo::Meta->new(class => $class); 305} 306 3071; 308} 309# ########################################################################### 310# End Lmo::Object package 311# ########################################################################### 312 313# ########################################################################### 314# Lmo::Types package 315# This package is a copy without comments from the original. The original 316# with comments and its test file can be found in the Bazaar repository at, 317# lib/Lmo/Types.pm 318# t/lib/Lmo/Types.t 319# See https://launchpad.net/percona-toolkit for more information. 320# ########################################################################### 321{ 322package Lmo::Types; 323 324use strict; 325use warnings qw( FATAL all ); 326 327use Carp (); 328use Scalar::Util qw(looks_like_number blessed); 329 330 331our %TYPES = ( 332 Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) }, 333 Num => sub { defined $_[0] && looks_like_number($_[0]) }, 334 Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) }, 335 Str => sub { defined $_[0] }, 336 Object => sub { defined $_[0] && blessed($_[0]) }, 337 FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, 338 339 map { 340 my $type = /R/ ? $_ : uc $_; 341 $_ . "Ref" => sub { ref $_[0] eq $type } 342 } qw(Array Code Hash Regexp Glob Scalar) 343); 344 345sub check_type_constaints { 346 my ($attribute, $type_check, $check_name, $val) = @_; 347 ( ref($type_check) eq 'CODE' 348 ? $type_check->($val) 349 : (ref $val eq $type_check 350 || ($val && $val eq $type_check) 351 || (exists $TYPES{$type_check} && $TYPES{$type_check}->($val))) 352 ) 353 || Carp::confess( 354 qq<Attribute ($attribute) does not pass the type constraint because: > 355 . qq<Validation failed for '$check_name' with value > 356 . (defined $val ? Lmo::Dumper($val) : 'undef') ) 357} 358 359sub _nested_constraints { 360 my ($attribute, $aggregate_type, $type) = @_; 361 362 my $inner_types; 363 if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { 364 $inner_types = _nested_constraints($1, $2); 365 } 366 else { 367 $inner_types = $TYPES{$type}; 368 } 369 370 if ( $aggregate_type eq 'ArrayRef' ) { 371 return sub { 372 my ($val) = @_; 373 return unless ref($val) eq ref([]); 374 375 if ($inner_types) { 376 for my $value ( @{$val} ) { 377 return unless $inner_types->($value) 378 } 379 } 380 else { 381 for my $value ( @{$val} ) { 382 return unless $value && ($value eq $type 383 || (Scalar::Util::blessed($value) && $value->isa($type))); 384 } 385 } 386 return 1; 387 }; 388 } 389 elsif ( $aggregate_type eq 'Maybe' ) { 390 return sub { 391 my ($value) = @_; 392 return 1 if ! defined($value); 393 if ($inner_types) { 394 return unless $inner_types->($value) 395 } 396 else { 397 return unless $value eq $type 398 || (Scalar::Util::blessed($value) && $value->isa($type)); 399 } 400 return 1; 401 } 402 } 403 else { 404 Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); 405 } 406} 407 4081; 409} 410# ########################################################################### 411# End Lmo::Types package 412# ########################################################################### 413 414# ########################################################################### 415# Lmo package 416# This package is a copy without comments from the original. The original 417# with comments and its test file can be found in the Bazaar repository at, 418# lib/Lmo.pm 419# t/lib/Lmo.t 420# See https://launchpad.net/percona-toolkit for more information. 421# ########################################################################### 422{ 423BEGIN { 424$INC{"Lmo.pm"} = __FILE__; 425package Lmo; 426our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. 427 428 429use strict; 430use warnings qw( FATAL all ); 431 432use Carp (); 433use Scalar::Util qw(looks_like_number blessed); 434 435use Lmo::Meta; 436use Lmo::Object; 437use Lmo::Types; 438 439use Lmo::Utils; 440 441my %export_for; 442sub import { 443 warnings->import(qw(FATAL all)); 444 strict->import(); 445 446 my $caller = scalar caller(); # Caller's package 447 my %exports = ( 448 extends => \&extends, 449 has => \&has, 450 with => \&with, 451 override => \&override, 452 confess => \&Carp::confess, 453 ); 454 455 $export_for{$caller} = \%exports; 456 457 for my $keyword ( keys %exports ) { 458 _install_coderef "${caller}::$keyword" => $exports{$keyword}; 459 } 460 461 if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) { 462 @_ = "Lmo::Object"; 463 goto *{ _glob_for "${caller}::extends" }{CODE}; 464 } 465} 466 467sub extends { 468 my $caller = scalar caller(); 469 for my $class ( @_ ) { 470 _load_module($class); 471 } 472 _set_package_isa($caller, @_); 473 _set_inherited_metadata($caller); 474} 475 476sub _load_module { 477 my ($class) = @_; 478 479 (my $file = $class) =~ s{::|'}{/}g; 480 $file .= '.pm'; 481 { local $@; eval { require "$file" } } # or warn $@; 482 return; 483} 484 485sub with { 486 my $package = scalar caller(); 487 require Role::Tiny; 488 for my $role ( @_ ) { 489 _load_module($role); 490 _role_attribute_metadata($package, $role); 491 } 492 Role::Tiny->apply_roles_to_package($package, @_); 493} 494 495sub _role_attribute_metadata { 496 my ($package, $role) = @_; 497 498 my $package_meta = Lmo::Meta->metadata_for($package); 499 my $role_meta = Lmo::Meta->metadata_for($role); 500 501 %$package_meta = (%$role_meta, %$package_meta); 502} 503 504sub has { 505 my $names = shift; 506 my $caller = scalar caller(); 507 508 my $class_metadata = Lmo::Meta->metadata_for($caller); 509 510 for my $attribute ( ref $names ? @$names : $names ) { 511 my %args = @_; 512 my $method = ($args{is} || '') eq 'ro' 513 ? sub { 514 Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}") 515 if $#_; 516 return $_[0]{$attribute}; 517 } 518 : sub { 519 return $#_ 520 ? $_[0]{$attribute} = $_[1] 521 : $_[0]{$attribute}; 522 }; 523 524 $class_metadata->{$attribute} = (); 525 526 if ( my $type_check = $args{isa} ) { 527 my $check_name = $type_check; 528 529 if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { 530 $type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type); 531 } 532 533 my $check_sub = sub { 534 my ($new_val) = @_; 535 Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val); 536 }; 537 538 $class_metadata->{$attribute}{isa} = [$check_name, $check_sub]; 539 my $orig_method = $method; 540 $method = sub { 541 $check_sub->($_[1]) if $#_; 542 goto &$orig_method; 543 }; 544 } 545 546 if ( my $builder = $args{builder} ) { 547 my $original_method = $method; 548 $method = sub { 549 $#_ 550 ? goto &$original_method 551 : ! exists $_[0]{$attribute} 552 ? $_[0]{$attribute} = $_[0]->$builder 553 : goto &$original_method 554 }; 555 } 556 557 if ( my $code = $args{default} ) { 558 Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") 559 unless ref($code) eq 'CODE'; 560 my $original_method = $method; 561 $method = sub { 562 $#_ 563 ? goto &$original_method 564 : ! exists $_[0]{$attribute} 565 ? $_[0]{$attribute} = $_[0]->$code 566 : goto &$original_method 567 }; 568 } 569 570 if ( my $role = $args{does} ) { 571 my $original_method = $method; 572 $method = sub { 573 if ( $#_ ) { 574 Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">) 575 unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) } 576 } 577 goto &$original_method 578 }; 579 } 580 581 if ( my $coercion = $args{coerce} ) { 582 $class_metadata->{$attribute}{coerce} = $coercion; 583 my $original_method = $method; 584 $method = sub { 585 if ( $#_ ) { 586 return $original_method->($_[0], $coercion->($_[1])) 587 } 588 goto &$original_method; 589 } 590 } 591 592 _install_coderef "${caller}::$attribute" => $method; 593 594 if ( $args{required} ) { 595 $class_metadata->{$attribute}{required} = 1; 596 } 597 598 if ($args{clearer}) { 599 _install_coderef "${caller}::$args{clearer}" 600 => sub { delete shift->{$attribute} } 601 } 602 603 if ($args{predicate}) { 604 _install_coderef "${caller}::$args{predicate}" 605 => sub { exists shift->{$attribute} } 606 } 607 608 if ($args{handles}) { 609 _has_handles($caller, $attribute, \%args); 610 } 611 612 if (exists $args{init_arg}) { 613 $class_metadata->{$attribute}{init_arg} = $args{init_arg}; 614 } 615 } 616} 617 618sub _has_handles { 619 my ($caller, $attribute, $args) = @_; 620 my $handles = $args->{handles}; 621 622 my $ref = ref $handles; 623 my $kv; 624 if ( $ref eq ref [] ) { 625 $kv = { map { $_,$_ } @{$handles} }; 626 } 627 elsif ( $ref eq ref {} ) { 628 $kv = $handles; 629 } 630 elsif ( $ref eq ref qr// ) { 631 Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") 632 unless $args->{isa}; 633 my $target_class = $args->{isa}; 634 $kv = { 635 map { $_, $_ } 636 grep { $_ =~ $handles } 637 grep { !exists $Lmo::Object::{$_} && $target_class->can($_) } 638 grep { !$export_for{$target_class}->{$_} } 639 keys %{ _stash_for $target_class } 640 }; 641 } 642 else { 643 Carp::confess("handles for $ref not yet implemented"); 644 } 645 646 while ( my ($method, $target) = each %{$kv} ) { 647 my $name = _glob_for "${caller}::$method"; 648 Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") 649 if defined &$name; 650 651 my ($target, @curried_args) = ref($target) ? @$target : $target; 652 *$name = sub { 653 my $self = shift; 654 my $delegate_to = $self->$attribute(); 655 my $error = "Cannot delegate $method to $target because the value of $attribute"; 656 Carp::confess("$error is not defined") unless $delegate_to; 657 Carp::confess("$error is not an object (got '$delegate_to')") 658 unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); 659 return $delegate_to->$target(@curried_args, @_); 660 } 661 } 662} 663 664sub _set_package_isa { 665 my ($package, @new_isa) = @_; 666 my $package_isa = \*{ _glob_for "${package}::ISA" }; 667 @{*$package_isa} = @new_isa; 668} 669 670sub _set_inherited_metadata { 671 my $class = shift; 672 my $class_metadata = Lmo::Meta->metadata_for($class); 673 my $linearized_isa = mro::get_linear_isa($class); 674 my %new_metadata; 675 676 for my $isa_class (reverse @$linearized_isa) { 677 my $isa_metadata = Lmo::Meta->metadata_for($isa_class); 678 %new_metadata = ( 679 %new_metadata, 680 %$isa_metadata, 681 ); 682 } 683 %$class_metadata = %new_metadata; 684} 685 686sub unimport { 687 my $caller = scalar caller(); 688 my $target = caller; 689 _unimport_coderefs($target, keys %{$export_for{$caller}}); 690} 691 692sub Dumper { 693 require Data::Dumper; 694 local $Data::Dumper::Indent = 0; 695 local $Data::Dumper::Sortkeys = 0; 696 local $Data::Dumper::Quotekeys = 0; 697 local $Data::Dumper::Terse = 1; 698 699 Data::Dumper::Dumper(@_) 700} 701 702BEGIN { 703 if ($] >= 5.010) { 704 { local $@; require mro; } 705 } 706 else { 707 local $@; 708 eval { 709 require MRO::Compat; 710 } or do { 711 *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { 712 no strict 'refs'; 713 714 my $classname = shift; 715 716 my @lin = ($classname); 717 my %stored; 718 foreach my $parent (@{"$classname\::ISA"}) { 719 my $plin = mro::get_linear_isa_dfs($parent); 720 foreach (@$plin) { 721 next if exists $stored{$_}; 722 push(@lin, $_); 723 $stored{$_} = 1; 724 } 725 } 726 return \@lin; 727 }; 728 } 729 } 730} 731 732sub override { 733 my ($methods, $code) = @_; 734 my $caller = scalar caller; 735 736 for my $method ( ref($methods) ? @$methods : $methods ) { 737 my $full_method = "${caller}::${method}"; 738 *{_glob_for $full_method} = $code; 739 } 740} 741 742} 7431; 744} 745# ########################################################################### 746# End Lmo package 747# ########################################################################### 748 749# ########################################################################### 750# OptionParser package 751# This package is a copy without comments from the original. The original 752# with comments and its test file can be found in the Bazaar repository at, 753# lib/OptionParser.pm 754# t/lib/OptionParser.t 755# See https://launchpad.net/percona-toolkit for more information. 756# ########################################################################### 757{ 758package OptionParser; 759 760use strict; 761use warnings FATAL => 'all'; 762use English qw(-no_match_vars); 763use constant PTDEBUG => $ENV{PTDEBUG} || 0; 764 765use List::Util qw(max); 766use Getopt::Long; 767use Data::Dumper; 768 769my $POD_link_re = '[LC]<"?([^">]+)"?>'; 770 771sub new { 772 my ( $class, %args ) = @_; 773 my @required_args = qw(); 774 foreach my $arg ( @required_args ) { 775 die "I need a $arg argument" unless $args{$arg}; 776 } 777 778 my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/; 779 $program_name ||= $PROGRAM_NAME; 780 my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.'; 781 782 my %attributes = ( 783 'type' => 1, 784 'short form' => 1, 785 'group' => 1, 786 'default' => 1, 787 'cumulative' => 1, 788 'negatable' => 1, 789 'repeatable' => 1, # means it can be specified more than once 790 ); 791 792 my $self = { 793 head1 => 'OPTIONS', # These args are used internally 794 skip_rules => 0, # to instantiate another Option- 795 item => '--(.*)', # Parser obj that parses the 796 attributes => \%attributes, # DSN OPTIONS section. Tools 797 parse_attributes => \&_parse_attribs, # don't tinker with these args. 798 799 %args, 800 801 strict => 1, # disabled by a special rule 802 program_name => $program_name, 803 opts => {}, 804 got_opts => 0, 805 short_opts => {}, 806 defaults => {}, 807 groups => {}, 808 allowed_groups => {}, 809 errors => [], 810 rules => [], # desc of rules for --help 811 mutex => [], # rule: opts are mutually exclusive 812 atleast1 => [], # rule: at least one opt is required 813 disables => {}, # rule: opt disables other opts 814 defaults_to => {}, # rule: opt defaults to value of other opt 815 DSNParser => undef, 816 default_files => [ 817 "/etc/percona-toolkit/percona-toolkit.conf", 818 "/etc/percona-toolkit/$program_name.conf", 819 "$home/.percona-toolkit.conf", 820 "$home/.$program_name.conf", 821 ], 822 types => { 823 string => 's', # standard Getopt type 824 int => 'i', # standard Getopt type 825 float => 'f', # standard Getopt type 826 Hash => 'H', # hash, formed from a comma-separated list 827 hash => 'h', # hash as above, but only if a value is given 828 Array => 'A', # array, similar to Hash 829 array => 'a', # array, similar to hash 830 DSN => 'd', # DSN 831 size => 'z', # size with kMG suffix (powers of 2^10) 832 time => 'm', # time, with an optional suffix of s/h/m/d 833 }, 834 }; 835 836 return bless $self, $class; 837} 838 839sub get_specs { 840 my ( $self, $file ) = @_; 841 $file ||= $self->{file} || __FILE__; 842 my @specs = $self->_pod_to_specs($file); 843 $self->_parse_specs(@specs); 844 845 open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 846 my $contents = do { local $/ = undef; <$fh> }; 847 close $fh; 848 if ( $contents =~ m/^=head1 DSN OPTIONS/m ) { 849 PTDEBUG && _d('Parsing DSN OPTIONS'); 850 my $dsn_attribs = { 851 dsn => 1, 852 copy => 1, 853 }; 854 my $parse_dsn_attribs = sub { 855 my ( $self, $option, $attribs ) = @_; 856 map { 857 my $val = $attribs->{$_}; 858 if ( $val ) { 859 $val = $val eq 'yes' ? 1 860 : $val eq 'no' ? 0 861 : $val; 862 $attribs->{$_} = $val; 863 } 864 } keys %$attribs; 865 return { 866 key => $option, 867 %$attribs, 868 }; 869 }; 870 my $dsn_o = new OptionParser( 871 description => 'DSN OPTIONS', 872 head1 => 'DSN OPTIONS', 873 dsn => 0, # XXX don't infinitely recurse! 874 item => '\* (.)', # key opts are a single character 875 skip_rules => 1, # no rules before opts 876 attributes => $dsn_attribs, 877 parse_attributes => $parse_dsn_attribs, 878 ); 879 my @dsn_opts = map { 880 my $opts = { 881 key => $_->{spec}->{key}, 882 dsn => $_->{spec}->{dsn}, 883 copy => $_->{spec}->{copy}, 884 desc => $_->{desc}, 885 }; 886 $opts; 887 } $dsn_o->_pod_to_specs($file); 888 $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts); 889 } 890 891 if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) { 892 $self->{version} = $1; 893 PTDEBUG && _d($self->{version}); 894 } 895 896 return; 897} 898 899sub DSNParser { 900 my ( $self ) = @_; 901 return $self->{DSNParser}; 902}; 903 904sub get_defaults_files { 905 my ( $self ) = @_; 906 return @{$self->{default_files}}; 907} 908 909sub _pod_to_specs { 910 my ( $self, $file ) = @_; 911 $file ||= $self->{file} || __FILE__; 912 open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR"; 913 914 my @specs = (); 915 my @rules = (); 916 my $para; 917 918 local $INPUT_RECORD_SEPARATOR = ''; 919 while ( $para = <$fh> ) { 920 next unless $para =~ m/^=head1 $self->{head1}/; 921 last; 922 } 923 924 while ( $para = <$fh> ) { 925 last if $para =~ m/^=over/; 926 next if $self->{skip_rules}; 927 chomp $para; 928 $para =~ s/\s+/ /g; 929 $para =~ s/$POD_link_re/$1/go; 930 PTDEBUG && _d('Option rule:', $para); 931 push @rules, $para; 932 } 933 934 die "POD has no $self->{head1} section" unless $para; 935 936 do { 937 if ( my ($option) = $para =~ m/^=item $self->{item}/ ) { 938 chomp $para; 939 PTDEBUG && _d($para); 940 my %attribs; 941 942 $para = <$fh>; # read next paragraph, possibly attributes 943 944 if ( $para =~ m/: / ) { # attributes 945 $para =~ s/\s+\Z//g; 946 %attribs = map { 947 my ( $attrib, $val) = split(/: /, $_); 948 die "Unrecognized attribute for --$option: $attrib" 949 unless $self->{attributes}->{$attrib}; 950 ($attrib, $val); 951 } split(/; /, $para); 952 if ( $attribs{'short form'} ) { 953 $attribs{'short form'} =~ s/-//; 954 } 955 $para = <$fh>; # read next paragraph, probably short help desc 956 } 957 else { 958 PTDEBUG && _d('Option has no attributes'); 959 } 960 961 $para =~ s/\s+\Z//g; 962 $para =~ s/\s+/ /g; 963 $para =~ s/$POD_link_re/$1/go; 964 965 $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s; 966 PTDEBUG && _d('Short help:', $para); 967 968 die "No description after option spec $option" if $para =~ m/^=item/; 969 970 if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) { 971 $option = $base_option; 972 $attribs{'negatable'} = 1; 973 } 974 975 push @specs, { 976 spec => $self->{parse_attributes}->($self, $option, \%attribs), 977 desc => $para 978 . (defined $attribs{default} ? " (default $attribs{default})" : ''), 979 group => ($attribs{'group'} ? $attribs{'group'} : 'default'), 980 attributes => \%attribs 981 }; 982 } 983 while ( $para = <$fh> ) { 984 last unless $para; 985 if ( $para =~ m/^=head1/ ) { 986 $para = undef; # Can't 'last' out of a do {} block. 987 last; 988 } 989 last if $para =~ m/^=item /; 990 } 991 } while ( $para ); 992 993 die "No valid specs in $self->{head1}" unless @specs; 994 995 close $fh; 996 return @specs, @rules; 997} 998 999sub _parse_specs { 1000 my ( $self, @specs ) = @_; 1001 my %disables; # special rule that requires deferred checking 1002 1003 foreach my $opt ( @specs ) { 1004 if ( ref $opt ) { # It's an option spec, not a rule. 1005 PTDEBUG && _d('Parsing opt spec:', 1006 map { ($_, '=>', $opt->{$_}) } keys %$opt); 1007 1008 my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/; 1009 if ( !$long ) { 1010 die "Cannot parse long option from spec $opt->{spec}"; 1011 } 1012 $opt->{long} = $long; 1013 1014 die "Duplicate long option --$long" if exists $self->{opts}->{$long}; 1015 $self->{opts}->{$long} = $opt; 1016 1017 if ( length $long == 1 ) { 1018 PTDEBUG && _d('Long opt', $long, 'looks like short opt'); 1019 $self->{short_opts}->{$long} = $long; 1020 } 1021 1022 if ( $short ) { 1023 die "Duplicate short option -$short" 1024 if exists $self->{short_opts}->{$short}; 1025 $self->{short_opts}->{$short} = $long; 1026 $opt->{short} = $short; 1027 } 1028 else { 1029 $opt->{short} = undef; 1030 } 1031 1032 $opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0; 1033 $opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0; 1034 $opt->{is_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0; 1035 $opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0; 1036 1037 $opt->{group} ||= 'default'; 1038 $self->{groups}->{ $opt->{group} }->{$long} = 1; 1039 1040 $opt->{value} = undef; 1041 $opt->{got} = 0; 1042 1043 my ( $type ) = $opt->{spec} =~ m/=(.)/; 1044 $opt->{type} = $type; 1045 PTDEBUG && _d($long, 'type:', $type); 1046 1047 1048 $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ ); 1049 1050 if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) { 1051 $self->{defaults}->{$long} = defined $def ? $def : 1; 1052 PTDEBUG && _d($long, 'default:', $def); 1053 } 1054 1055 if ( $long eq 'config' ) { 1056 $self->{defaults}->{$long} = join(',', $self->get_defaults_files()); 1057 } 1058 1059 if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) { 1060 $disables{$long} = $dis; 1061 PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis); 1062 } 1063 1064 $self->{opts}->{$long} = $opt; 1065 } 1066 else { # It's an option rule, not a spec. 1067 PTDEBUG && _d('Parsing rule:', $opt); 1068 push @{$self->{rules}}, $opt; 1069 my @participants = $self->_get_participants($opt); 1070 my $rule_ok = 0; 1071 1072 if ( $opt =~ m/mutually exclusive|one and only one/ ) { 1073 $rule_ok = 1; 1074 push @{$self->{mutex}}, \@participants; 1075 PTDEBUG && _d(@participants, 'are mutually exclusive'); 1076 } 1077 if ( $opt =~ m/at least one|one and only one/ ) { 1078 $rule_ok = 1; 1079 push @{$self->{atleast1}}, \@participants; 1080 PTDEBUG && _d(@participants, 'require at least one'); 1081 } 1082 if ( $opt =~ m/default to/ ) { 1083 $rule_ok = 1; 1084 $self->{defaults_to}->{$participants[0]} = $participants[1]; 1085 PTDEBUG && _d($participants[0], 'defaults to', $participants[1]); 1086 } 1087 if ( $opt =~ m/restricted to option groups/ ) { 1088 $rule_ok = 1; 1089 my ($groups) = $opt =~ m/groups ([\w\s\,]+)/; 1090 my @groups = split(',', $groups); 1091 %{$self->{allowed_groups}->{$participants[0]}} = map { 1092 s/\s+//; 1093 $_ => 1; 1094 } @groups; 1095 } 1096 if( $opt =~ m/accepts additional command-line arguments/ ) { 1097 $rule_ok = 1; 1098 $self->{strict} = 0; 1099 PTDEBUG && _d("Strict mode disabled by rule"); 1100 } 1101 1102 die "Unrecognized option rule: $opt" unless $rule_ok; 1103 } 1104 } 1105 1106 foreach my $long ( keys %disables ) { 1107 my @participants = $self->_get_participants($disables{$long}); 1108 $self->{disables}->{$long} = \@participants; 1109 PTDEBUG && _d('Option', $long, 'disables', @participants); 1110 } 1111 1112 return; 1113} 1114 1115sub _get_participants { 1116 my ( $self, $str ) = @_; 1117 my @participants; 1118 foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) { 1119 die "Option --$long does not exist while processing rule $str" 1120 unless exists $self->{opts}->{$long}; 1121 push @participants, $long; 1122 } 1123 PTDEBUG && _d('Participants for', $str, ':', @participants); 1124 return @participants; 1125} 1126 1127sub opts { 1128 my ( $self ) = @_; 1129 my %opts = %{$self->{opts}}; 1130 return %opts; 1131} 1132 1133sub short_opts { 1134 my ( $self ) = @_; 1135 my %short_opts = %{$self->{short_opts}}; 1136 return %short_opts; 1137} 1138 1139sub set_defaults { 1140 my ( $self, %defaults ) = @_; 1141 $self->{defaults} = {}; 1142 foreach my $long ( keys %defaults ) { 1143 die "Cannot set default for nonexistent option $long" 1144 unless exists $self->{opts}->{$long}; 1145 $self->{defaults}->{$long} = $defaults{$long}; 1146 PTDEBUG && _d('Default val for', $long, ':', $defaults{$long}); 1147 } 1148 return; 1149} 1150 1151sub get_defaults { 1152 my ( $self ) = @_; 1153 return $self->{defaults}; 1154} 1155 1156sub get_groups { 1157 my ( $self ) = @_; 1158 return $self->{groups}; 1159} 1160 1161sub _set_option { 1162 my ( $self, $opt, $val ) = @_; 1163 my $long = exists $self->{opts}->{$opt} ? $opt 1164 : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt} 1165 : die "Getopt::Long gave a nonexistent option: $opt"; 1166 $opt = $self->{opts}->{$long}; 1167 if ( $opt->{is_cumulative} ) { 1168 $opt->{value}++; 1169 } 1170 elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) { 1171 my $next_opt = $1; 1172 if ( exists $self->{opts}->{$next_opt} 1173 || exists $self->{short_opts}->{$next_opt} ) { 1174 $self->save_error("--$long requires a string value"); 1175 return; 1176 } 1177 else { 1178 if ($opt->{is_repeatable}) { 1179 push @{$opt->{value}} , $val; 1180 } 1181 else { 1182 $opt->{value} = $val; 1183 } 1184 } 1185 } 1186 else { 1187 if ($opt->{is_repeatable}) { 1188 push @{$opt->{value}} , $val; 1189 } 1190 else { 1191 $opt->{value} = $val; 1192 } 1193 } 1194 $opt->{got} = 1; 1195 PTDEBUG && _d('Got option', $long, '=', $val); 1196} 1197 1198sub get_opts { 1199 my ( $self ) = @_; 1200 1201 foreach my $long ( keys %{$self->{opts}} ) { 1202 $self->{opts}->{$long}->{got} = 0; 1203 $self->{opts}->{$long}->{value} 1204 = exists $self->{defaults}->{$long} ? $self->{defaults}->{$long} 1205 : $self->{opts}->{$long}->{is_cumulative} ? 0 1206 : undef; 1207 } 1208 $self->{got_opts} = 0; 1209 1210 $self->{errors} = []; 1211 1212 if ( @ARGV && $ARGV[0] =~/^--config=/ ) { 1213 $ARGV[0] = substr($ARGV[0],9); 1214 $ARGV[0] =~ s/^'(.*)'$/$1/; 1215 $ARGV[0] =~ s/^"(.*)"$/$1/; 1216 $self->_set_option('config', shift @ARGV); 1217 } 1218 if ( @ARGV && $ARGV[0] eq "--config" ) { 1219 shift @ARGV; 1220 $self->_set_option('config', shift @ARGV); 1221 } 1222 if ( $self->has('config') ) { 1223 my @extra_args; 1224 foreach my $filename ( split(',', $self->get('config')) ) { 1225 eval { 1226 push @extra_args, $self->_read_config_file($filename); 1227 }; 1228 if ( $EVAL_ERROR ) { 1229 if ( $self->got('config') ) { 1230 die $EVAL_ERROR; 1231 } 1232 elsif ( PTDEBUG ) { 1233 _d($EVAL_ERROR); 1234 } 1235 } 1236 } 1237 unshift @ARGV, @extra_args; 1238 } 1239 1240 Getopt::Long::Configure('no_ignore_case', 'bundling'); 1241 GetOptions( 1242 map { $_->{spec} => sub { $self->_set_option(@_); } } 1243 grep { $_->{long} ne 'config' } # --config is handled specially above. 1244 values %{$self->{opts}} 1245 ) or $self->save_error('Error parsing options'); 1246 1247 if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) { 1248 if ( $self->{version} ) { 1249 print $self->{version}, "\n"; 1250 exit 0; 1251 } 1252 else { 1253 print "Error parsing version. See the VERSION section of the tool's documentation.\n"; 1254 exit 1; 1255 } 1256 } 1257 1258 if ( @ARGV && $self->{strict} ) { 1259 $self->save_error("Unrecognized command-line options @ARGV"); 1260 } 1261 1262 foreach my $mutex ( @{$self->{mutex}} ) { 1263 my @set = grep { $self->{opts}->{$_}->{got} } @$mutex; 1264 if ( @set > 1 ) { 1265 my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } 1266 @{$mutex}[ 0 .. scalar(@$mutex) - 2] ) 1267 . ' and --'.$self->{opts}->{$mutex->[-1]}->{long} 1268 . ' are mutually exclusive.'; 1269 $self->save_error($err); 1270 } 1271 } 1272 1273 foreach my $required ( @{$self->{atleast1}} ) { 1274 my @set = grep { $self->{opts}->{$_}->{got} } @$required; 1275 if ( @set == 0 ) { 1276 my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } 1277 @{$required}[ 0 .. scalar(@$required) - 2] ) 1278 .' or --'.$self->{opts}->{$required->[-1]}->{long}; 1279 $self->save_error("Specify at least one of $err"); 1280 } 1281 } 1282 1283 $self->_check_opts( keys %{$self->{opts}} ); 1284 $self->{got_opts} = 1; 1285 return; 1286} 1287 1288sub _check_opts { 1289 my ( $self, @long ) = @_; 1290 my $long_last = scalar @long; 1291 while ( @long ) { 1292 foreach my $i ( 0..$#long ) { 1293 my $long = $long[$i]; 1294 next unless $long; 1295 my $opt = $self->{opts}->{$long}; 1296 if ( $opt->{got} ) { 1297 if ( exists $self->{disables}->{$long} ) { 1298 my @disable_opts = @{$self->{disables}->{$long}}; 1299 map { $self->{opts}->{$_}->{value} = undef; } @disable_opts; 1300 PTDEBUG && _d('Unset options', @disable_opts, 1301 'because', $long,'disables them'); 1302 } 1303 1304 if ( exists $self->{allowed_groups}->{$long} ) { 1305 1306 my @restricted_groups = grep { 1307 !exists $self->{allowed_groups}->{$long}->{$_} 1308 } keys %{$self->{groups}}; 1309 1310 my @restricted_opts; 1311 foreach my $restricted_group ( @restricted_groups ) { 1312 RESTRICTED_OPT: 1313 foreach my $restricted_opt ( 1314 keys %{$self->{groups}->{$restricted_group}} ) 1315 { 1316 next RESTRICTED_OPT if $restricted_opt eq $long; 1317 push @restricted_opts, $restricted_opt 1318 if $self->{opts}->{$restricted_opt}->{got}; 1319 } 1320 } 1321 1322 if ( @restricted_opts ) { 1323 my $err; 1324 if ( @restricted_opts == 1 ) { 1325 $err = "--$restricted_opts[0]"; 1326 } 1327 else { 1328 $err = join(', ', 1329 map { "--$self->{opts}->{$_}->{long}" } 1330 grep { $_ } 1331 @restricted_opts[0..scalar(@restricted_opts) - 2] 1332 ) 1333 . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long}; 1334 } 1335 $self->save_error("--$long is not allowed with $err"); 1336 } 1337 } 1338 1339 } 1340 elsif ( $opt->{is_required} ) { 1341 $self->save_error("Required option --$long must be specified"); 1342 } 1343 1344 $self->_validate_type($opt); 1345 if ( $opt->{parsed} ) { 1346 delete $long[$i]; 1347 } 1348 else { 1349 PTDEBUG && _d('Temporarily failed to parse', $long); 1350 } 1351 } 1352 1353 die "Failed to parse options, possibly due to circular dependencies" 1354 if @long == $long_last; 1355 $long_last = @long; 1356 } 1357 1358 return; 1359} 1360 1361sub _validate_type { 1362 my ( $self, $opt ) = @_; 1363 return unless $opt; 1364 1365 if ( !$opt->{type} ) { 1366 $opt->{parsed} = 1; 1367 return; 1368 } 1369 1370 my $val = $opt->{value}; 1371 1372 if ( $val && $opt->{type} eq 'm' ) { # type time 1373 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value'); 1374 my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/; 1375 if ( !$suffix ) { 1376 my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/; 1377 $suffix = $s || 's'; 1378 PTDEBUG && _d('No suffix given; using', $suffix, 'for', 1379 $opt->{long}, '(value:', $val, ')'); 1380 } 1381 if ( $suffix =~ m/[smhd]/ ) { 1382 $val = $suffix eq 's' ? $num # Seconds 1383 : $suffix eq 'm' ? $num * 60 # Minutes 1384 : $suffix eq 'h' ? $num * 3600 # Hours 1385 : $num * 86400; # Days 1386 $opt->{value} = ($prefix || '') . $val; 1387 PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val); 1388 } 1389 else { 1390 $self->save_error("Invalid time suffix for --$opt->{long}"); 1391 } 1392 } 1393 elsif ( $val && $opt->{type} eq 'd' ) { # type DSN 1394 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN'); 1395 my $prev = {}; 1396 my $from_key = $self->{defaults_to}->{ $opt->{long} }; 1397 if ( $from_key ) { 1398 PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN'); 1399 if ( $self->{opts}->{$from_key}->{parsed} ) { 1400 $prev = $self->{opts}->{$from_key}->{value}; 1401 } 1402 else { 1403 PTDEBUG && _d('Cannot parse', $opt->{long}, 'until', 1404 $from_key, 'parsed'); 1405 return; 1406 } 1407 } 1408 my $defaults = $self->{DSNParser}->parse_options($self); 1409 if (!$opt->{attributes}->{repeatable}) { 1410 $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults); 1411 } else { 1412 my $values = []; 1413 for my $dsn_string (@$val) { 1414 push @$values, $self->{DSNParser}->parse($dsn_string, $prev, $defaults); 1415 } 1416 $opt->{value} = $values; 1417 } 1418 } 1419 elsif ( $val && $opt->{type} eq 'z' ) { # type size 1420 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value'); 1421 $self->_parse_size($opt, $val); 1422 } 1423 elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) { 1424 $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) }; 1425 } 1426 elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) { 1427 $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ]; 1428 } 1429 else { 1430 PTDEBUG && _d('Nothing to validate for option', 1431 $opt->{long}, 'type', $opt->{type}, 'value', $val); 1432 } 1433 1434 $opt->{parsed} = 1; 1435 return; 1436} 1437 1438sub get { 1439 my ( $self, $opt ) = @_; 1440 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 1441 die "Option $opt does not exist" 1442 unless $long && exists $self->{opts}->{$long}; 1443 return $self->{opts}->{$long}->{value}; 1444} 1445 1446sub got { 1447 my ( $self, $opt ) = @_; 1448 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 1449 die "Option $opt does not exist" 1450 unless $long && exists $self->{opts}->{$long}; 1451 return $self->{opts}->{$long}->{got}; 1452} 1453 1454sub has { 1455 my ( $self, $opt ) = @_; 1456 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 1457 return defined $long ? exists $self->{opts}->{$long} : 0; 1458} 1459 1460sub set { 1461 my ( $self, $opt, $val ) = @_; 1462 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 1463 die "Option $opt does not exist" 1464 unless $long && exists $self->{opts}->{$long}; 1465 $self->{opts}->{$long}->{value} = $val; 1466 return; 1467} 1468 1469sub save_error { 1470 my ( $self, $error ) = @_; 1471 push @{$self->{errors}}, $error; 1472 return; 1473} 1474 1475sub errors { 1476 my ( $self ) = @_; 1477 return $self->{errors}; 1478} 1479 1480sub usage { 1481 my ( $self ) = @_; 1482 warn "No usage string is set" unless $self->{usage}; # XXX 1483 return "Usage: " . ($self->{usage} || '') . "\n"; 1484} 1485 1486sub descr { 1487 my ( $self ) = @_; 1488 warn "No description string is set" unless $self->{description}; # XXX 1489 my $descr = ($self->{description} || $self->{program_name} || '') 1490 . " For more details, please use the --help option, " 1491 . "or try 'perldoc $PROGRAM_NAME' " 1492 . "for complete documentation."; 1493 $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g) 1494 unless $ENV{DONT_BREAK_LINES}; 1495 $descr =~ s/ +$//mg; 1496 return $descr; 1497} 1498 1499sub usage_or_errors { 1500 my ( $self, $file, $return ) = @_; 1501 $file ||= $self->{file} || __FILE__; 1502 1503 if ( !$self->{description} || !$self->{usage} ) { 1504 PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file); 1505 my %synop = $self->_parse_synopsis($file); 1506 $self->{description} ||= $synop{description}; 1507 $self->{usage} ||= $synop{usage}; 1508 PTDEBUG && _d("Description:", $self->{description}, 1509 "\nUsage:", $self->{usage}); 1510 } 1511 1512 if ( $self->{opts}->{help}->{got} ) { 1513 print $self->print_usage() or die "Cannot print usage: $OS_ERROR"; 1514 exit 0 unless $return; 1515 } 1516 elsif ( scalar @{$self->{errors}} ) { 1517 print $self->print_errors() or die "Cannot print errors: $OS_ERROR"; 1518 exit 1 unless $return; 1519 } 1520 1521 return; 1522} 1523 1524sub print_errors { 1525 my ( $self ) = @_; 1526 my $usage = $self->usage() . "\n"; 1527 if ( (my @errors = @{$self->{errors}}) ) { 1528 $usage .= join("\n * ", 'Errors in command-line arguments:', @errors) 1529 . "\n"; 1530 } 1531 return $usage . "\n" . $self->descr(); 1532} 1533 1534sub print_usage { 1535 my ( $self ) = @_; 1536 die "Run get_opts() before print_usage()" unless $self->{got_opts}; 1537 my @opts = values %{$self->{opts}}; 1538 1539 my $maxl = max( 1540 map { 1541 length($_->{long}) # option long name 1542 + ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable 1543 + ($_->{type} ? 2 : 0) # "=x" where x is the opt type 1544 } 1545 @opts); 1546 1547 my $maxs = max(0, 1548 map { 1549 length($_) 1550 + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0) 1551 + ($self->{opts}->{$_}->{type} ? 2 : 0) 1552 } 1553 values %{$self->{short_opts}}); 1554 1555 my $lcol = max($maxl, ($maxs + 3)); 1556 my $rcol = 80 - $lcol - 6; 1557 my $rpad = ' ' x ( 80 - $rcol ); 1558 1559 $maxs = max($lcol - 3, $maxs); 1560 1561 my $usage = $self->descr() . "\n" . $self->usage(); 1562 1563 my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}}; 1564 push @groups, 'default'; 1565 1566 foreach my $group ( reverse @groups ) { 1567 $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n"; 1568 foreach my $opt ( 1569 sort { $a->{long} cmp $b->{long} } 1570 grep { $_->{group} eq $group } 1571 @opts ) 1572 { 1573 my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long}; 1574 my $short = $opt->{short}; 1575 my $desc = $opt->{desc}; 1576 1577 $long .= $opt->{type} ? "=$opt->{type}" : ""; 1578 1579 if ( $opt->{type} && $opt->{type} eq 'm' ) { 1580 my ($s) = $desc =~ m/\(suffix (.)\)/; 1581 $s ||= 's'; 1582 $desc =~ s/\s+\(suffix .\)//; 1583 $desc .= ". Optional suffix s=seconds, m=minutes, h=hours, " 1584 . "d=days; if no suffix, $s is used."; 1585 } 1586 $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g); 1587 $desc =~ s/ +$//mg; 1588 if ( $short ) { 1589 $usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc); 1590 } 1591 else { 1592 $usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc); 1593 } 1594 } 1595 } 1596 1597 $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n"; 1598 1599 if ( (my @rules = @{$self->{rules}}) ) { 1600 $usage .= "\nRules:\n\n"; 1601 $usage .= join("\n", map { " $_" } @rules) . "\n"; 1602 } 1603 if ( $self->{DSNParser} ) { 1604 $usage .= "\n" . $self->{DSNParser}->usage(); 1605 } 1606 $usage .= "\nOptions and values after processing arguments:\n\n"; 1607 foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) { 1608 my $val = $opt->{value}; 1609 my $type = $opt->{type} || ''; 1610 my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/; 1611 $val = $bool ? ( $val ? 'TRUE' : 'FALSE' ) 1612 : !defined $val ? '(No value)' 1613 : $type eq 'd' ? $self->{DSNParser}->as_string($val) 1614 : $type =~ m/H|h/ ? join(',', sort keys %$val) 1615 : $type =~ m/A|a/ ? join(',', @$val) 1616 : $val; 1617 $usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val); 1618 } 1619 return $usage; 1620} 1621 1622sub prompt_noecho { 1623 shift @_ if ref $_[0] eq __PACKAGE__; 1624 my ( $prompt ) = @_; 1625 local $OUTPUT_AUTOFLUSH = 1; 1626 print STDERR $prompt 1627 or die "Cannot print: $OS_ERROR"; 1628 my $response; 1629 eval { 1630 require Term::ReadKey; 1631 Term::ReadKey::ReadMode('noecho'); 1632 chomp($response = <STDIN>); 1633 Term::ReadKey::ReadMode('normal'); 1634 print "\n" 1635 or die "Cannot print: $OS_ERROR"; 1636 }; 1637 if ( $EVAL_ERROR ) { 1638 die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR"; 1639 } 1640 return $response; 1641} 1642 1643sub _read_config_file { 1644 my ( $self, $filename ) = @_; 1645 open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n"; 1646 my @args; 1647 my $prefix = '--'; 1648 my $parse = 1; 1649 1650 LINE: 1651 while ( my $line = <$fh> ) { 1652 chomp $line; 1653 next LINE if $line =~ m/^\s*(?:\#|\;|$)/; 1654 $line =~ s/\s+#.*$//g; 1655 $line =~ s/^\s+|\s+$//g; 1656 if ( $line eq '--' ) { 1657 $prefix = ''; 1658 $parse = 0; 1659 next LINE; 1660 } 1661 1662 if ( $parse 1663 && !$self->has('version-check') 1664 && $line =~ /version-check/ 1665 ) { 1666 next LINE; 1667 } 1668 1669 if ( $parse 1670 && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/) 1671 ) { 1672 push @args, grep { defined $_ } ("$prefix$opt", $arg); 1673 } 1674 elsif ( $line =~ m/./ ) { 1675 push @args, $line; 1676 } 1677 else { 1678 die "Syntax error in file $filename at line $INPUT_LINE_NUMBER"; 1679 } 1680 } 1681 close $fh; 1682 return @args; 1683} 1684 1685sub read_para_after { 1686 my ( $self, $file, $regex ) = @_; 1687 open my $fh, "<", $file or die "Can't open $file: $OS_ERROR"; 1688 local $INPUT_RECORD_SEPARATOR = ''; 1689 my $para; 1690 while ( $para = <$fh> ) { 1691 next unless $para =~ m/^=pod$/m; 1692 last; 1693 } 1694 while ( $para = <$fh> ) { 1695 next unless $para =~ m/$regex/; 1696 last; 1697 } 1698 $para = <$fh>; 1699 chomp($para); 1700 close $fh or die "Can't close $file: $OS_ERROR"; 1701 return $para; 1702} 1703 1704sub clone { 1705 my ( $self ) = @_; 1706 1707 my %clone = map { 1708 my $hashref = $self->{$_}; 1709 my $val_copy = {}; 1710 foreach my $key ( keys %$hashref ) { 1711 my $ref = ref $hashref->{$key}; 1712 $val_copy->{$key} = !$ref ? $hashref->{$key} 1713 : $ref eq 'HASH' ? { %{$hashref->{$key}} } 1714 : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ] 1715 : $hashref->{$key}; 1716 } 1717 $_ => $val_copy; 1718 } qw(opts short_opts defaults); 1719 1720 foreach my $scalar ( qw(got_opts) ) { 1721 $clone{$scalar} = $self->{$scalar}; 1722 } 1723 1724 return bless \%clone; 1725} 1726 1727sub _parse_size { 1728 my ( $self, $opt, $val ) = @_; 1729 1730 if ( lc($val || '') eq 'null' ) { 1731 PTDEBUG && _d('NULL size for', $opt->{long}); 1732 $opt->{value} = 'null'; 1733 return; 1734 } 1735 1736 my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824); 1737 my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/; 1738 if ( defined $num ) { 1739 if ( $factor ) { 1740 $num *= $factor_for{$factor}; 1741 PTDEBUG && _d('Setting option', $opt->{y}, 1742 'to num', $num, '* factor', $factor); 1743 } 1744 $opt->{value} = ($pre || '') . $num; 1745 } 1746 else { 1747 $self->save_error("Invalid size for --$opt->{long}: $val"); 1748 } 1749 return; 1750} 1751 1752sub _parse_attribs { 1753 my ( $self, $option, $attribs ) = @_; 1754 my $types = $self->{types}; 1755 return $option 1756 . ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' ) 1757 . ($attribs->{'negatable'} ? '!' : '' ) 1758 . ($attribs->{'cumulative'} ? '+' : '' ) 1759 . ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' ); 1760} 1761 1762sub _parse_synopsis { 1763 my ( $self, $file ) = @_; 1764 $file ||= $self->{file} || __FILE__; 1765 PTDEBUG && _d("Parsing SYNOPSIS in", $file); 1766 1767 local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs 1768 open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 1769 my $para; 1770 1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/; 1771 die "$file does not contain a SYNOPSIS section" unless $para; 1772 my @synop; 1773 for ( 1..2 ) { # 1 for the usage, 2 for the description 1774 my $para = <$fh>; 1775 push @synop, $para; 1776 } 1777 close $fh; 1778 PTDEBUG && _d("Raw SYNOPSIS text:", @synop); 1779 my ($usage, $desc) = @synop; 1780 die "The SYNOPSIS section in $file is not formatted properly" 1781 unless $usage && $desc; 1782 1783 $usage =~ s/^\s*Usage:\s+(.+)/$1/; 1784 chomp $usage; 1785 1786 $desc =~ s/\n/ /g; 1787 $desc =~ s/\s{2,}/ /g; 1788 $desc =~ s/\. ([A-Z][a-z])/. $1/g; 1789 $desc =~ s/\s+$//; 1790 1791 return ( 1792 description => $desc, 1793 usage => $usage, 1794 ); 1795}; 1796 1797sub set_vars { 1798 my ($self, $file) = @_; 1799 $file ||= $self->{file} || __FILE__; 1800 1801 my %user_vars; 1802 my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef; 1803 if ( $user_vars ) { 1804 foreach my $var_val ( @$user_vars ) { 1805 my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; 1806 die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; 1807 $user_vars{$var} = { 1808 val => $val, 1809 default => 0, 1810 }; 1811 } 1812 } 1813 1814 my %default_vars; 1815 my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/); 1816 if ( $default_vars ) { 1817 %default_vars = map { 1818 my $var_val = $_; 1819 my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; 1820 die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; 1821 $var => { 1822 val => $val, 1823 default => 1, 1824 }; 1825 } split("\n", $default_vars); 1826 } 1827 1828 my %vars = ( 1829 %default_vars, # first the tool's defaults 1830 %user_vars, # then the user's which overwrite the defaults 1831 ); 1832 PTDEBUG && _d('--set-vars:', Dumper(\%vars)); 1833 return \%vars; 1834} 1835 1836sub _d { 1837 my ($package, undef, $line) = caller 0; 1838 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 1839 map { defined $_ ? $_ : 'undef' } 1840 @_; 1841 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 1842} 1843 1844if ( PTDEBUG ) { 1845 print STDERR '# ', $^X, ' ', $], "\n"; 1846 if ( my $uname = `uname -a` ) { 1847 $uname =~ s/\s+/ /g; 1848 print STDERR "# $uname\n"; 1849 } 1850 print STDERR '# Arguments: ', 1851 join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n"; 1852} 1853 18541; 1855} 1856# ########################################################################### 1857# End OptionParser package 1858# ########################################################################### 1859 1860# ########################################################################### 1861# TableParser package 1862# This package is a copy without comments from the original. The original 1863# with comments and its test file can be found in the Bazaar repository at, 1864# lib/TableParser.pm 1865# t/lib/TableParser.t 1866# See https://launchpad.net/percona-toolkit for more information. 1867# ########################################################################### 1868{ 1869package TableParser; 1870 1871use strict; 1872use warnings FATAL => 'all'; 1873use English qw(-no_match_vars); 1874use constant PTDEBUG => $ENV{PTDEBUG} || 0; 1875 1876use Data::Dumper; 1877$Data::Dumper::Indent = 1; 1878$Data::Dumper::Sortkeys = 1; 1879$Data::Dumper::Quotekeys = 0; 1880 1881local $EVAL_ERROR; 1882eval { 1883 require Quoter; 1884}; 1885 1886sub new { 1887 my ( $class, %args ) = @_; 1888 my $self = { %args }; 1889 $self->{Quoter} ||= Quoter->new(); 1890 return bless $self, $class; 1891} 1892 1893sub Quoter { shift->{Quoter} } 1894 1895sub get_create_table { 1896 my ( $self, $dbh, $db, $tbl ) = @_; 1897 die "I need a dbh parameter" unless $dbh; 1898 die "I need a db parameter" unless $db; 1899 die "I need a tbl parameter" unless $tbl; 1900 my $q = $self->{Quoter}; 1901 1902 my $new_sql_mode 1903 = q{/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, } 1904 . q{@@SQL_MODE := '', } 1905 . q{@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, } 1906 . q{@@SQL_QUOTE_SHOW_CREATE := 1 */}; 1907 1908 my $old_sql_mode 1909 = q{/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, } 1910 . q{@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */}; 1911 1912 PTDEBUG && _d($new_sql_mode); 1913 eval { $dbh->do($new_sql_mode); }; 1914 PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR); 1915 1916 my $use_sql = 'USE ' . $q->quote($db); 1917 PTDEBUG && _d($dbh, $use_sql); 1918 $dbh->do($use_sql); 1919 1920 my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl); 1921 PTDEBUG && _d($show_sql); 1922 my $href; 1923 eval { $href = $dbh->selectrow_hashref($show_sql); }; 1924 if ( my $e = $EVAL_ERROR ) { 1925 PTDEBUG && _d($old_sql_mode); 1926 $dbh->do($old_sql_mode); 1927 1928 die $e; 1929 } 1930 1931 PTDEBUG && _d($old_sql_mode); 1932 $dbh->do($old_sql_mode); 1933 1934 my ($key) = grep { m/create (?:table|view)/i } keys %$href; 1935 if ( !$key ) { 1936 die "Error: no 'Create Table' or 'Create View' in result set from " 1937 . "$show_sql: " . Dumper($href); 1938 } 1939 1940 return $href->{$key}; 1941} 1942 1943sub parse { 1944 my ( $self, $ddl, $opts ) = @_; 1945 return unless $ddl; 1946 1947 if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) { 1948 $ddl = $self->ansi_to_legacy($ddl); 1949 } 1950 elsif ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) { 1951 die "TableParser doesn't handle CREATE TABLE without quoting."; 1952 } 1953 1954 my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/; 1955 (undef, $name) = $self->{Quoter}->split_unquote($name) if $name; 1956 1957 $ddl =~ s/(`[^`\n]+`)/\L$1/gm; 1958 1959 my $engine = $self->get_engine($ddl); 1960 1961 my @defs = $ddl =~ m/^(\s+`.*?),?$/gm; 1962 my @cols = map { $_ =~ m/`([^`]+)`/ } @defs; 1963 PTDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols)); 1964 1965 my %def_for; 1966 @def_for{@cols} = @defs; 1967 1968 my (@nums, @null, @non_generated); 1969 my (%type_for, %is_nullable, %is_numeric, %is_autoinc, %is_generated); 1970 foreach my $col ( @cols ) { 1971 my $def = $def_for{$col}; 1972 1973 $def =~ s/``//g; 1974 1975 my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/; 1976 die "Can't determine column type for $def" unless $type; 1977 $type_for{$col} = $type; 1978 if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) { 1979 push @nums, $col; 1980 $is_numeric{$col} = 1; 1981 } 1982 if ( $def !~ m/NOT NULL/ ) { 1983 push @null, $col; 1984 $is_nullable{$col} = 1; 1985 } 1986 if ( remove_quoted_text($def) =~ m/\WGENERATED\W/i ) { 1987 $is_generated{$col} = 1; 1988 } else { 1989 push @non_generated, $col; 1990 } 1991 $is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0; 1992 } 1993 1994 my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable); 1995 1996 my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/; 1997 1998 return { 1999 name => $name, 2000 cols => \@cols, 2001 col_posn => { map { $cols[$_] => $_ } 0..$#cols }, 2002 is_col => { map { $_ => 1 } @non_generated }, 2003 null_cols => \@null, 2004 is_nullable => \%is_nullable, 2005 non_generated_cols => \@non_generated, 2006 is_autoinc => \%is_autoinc, 2007 is_generated => \%is_generated, 2008 clustered_key => $clustered_key, 2009 keys => $keys, 2010 defs => \%def_for, 2011 numeric_cols => \@nums, 2012 is_numeric => \%is_numeric, 2013 engine => $engine, 2014 type_for => \%type_for, 2015 charset => $charset, 2016 }; 2017} 2018 2019sub remove_quoted_text { 2020 my ($string) = @_; 2021 $string =~ s/[^\\]`[^`]*[^\\]`//g; 2022 $string =~ s/[^\\]"[^"]*[^\\]"//g; 2023 $string =~ s/[^\\]'[^']*[^\\]'//g; 2024 return $string; 2025} 2026 2027sub sort_indexes { 2028 my ( $self, $tbl ) = @_; 2029 2030 my @indexes 2031 = sort { 2032 (($a ne 'PRIMARY') <=> ($b ne 'PRIMARY')) 2033 || ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} ) 2034 || ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} ) 2035 || ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) ) 2036 } 2037 grep { 2038 $tbl->{keys}->{$_}->{type} eq 'BTREE' 2039 } 2040 sort keys %{$tbl->{keys}}; 2041 2042 PTDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes)); 2043 return @indexes; 2044} 2045 2046sub find_best_index { 2047 my ( $self, $tbl, $index ) = @_; 2048 my $best; 2049 if ( $index ) { 2050 ($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}}; 2051 } 2052 if ( !$best ) { 2053 if ( $index ) { 2054 die "Index '$index' does not exist in table"; 2055 } 2056 else { 2057 ($best) = $self->sort_indexes($tbl); 2058 } 2059 } 2060 PTDEBUG && _d('Best index found is', $best); 2061 return $best; 2062} 2063 2064sub find_possible_keys { 2065 my ( $self, $dbh, $database, $table, $quoter, $where ) = @_; 2066 return () unless $where; 2067 my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table) 2068 . ' WHERE ' . $where; 2069 PTDEBUG && _d($sql); 2070 my $expl = $dbh->selectrow_hashref($sql); 2071 $expl = { map { lc($_) => $expl->{$_} } keys %$expl }; 2072 if ( $expl->{possible_keys} ) { 2073 PTDEBUG && _d('possible_keys =', $expl->{possible_keys}); 2074 my @candidates = split(',', $expl->{possible_keys}); 2075 my %possible = map { $_ => 1 } @candidates; 2076 if ( $expl->{key} ) { 2077 PTDEBUG && _d('MySQL chose', $expl->{key}); 2078 unshift @candidates, grep { $possible{$_} } split(',', $expl->{key}); 2079 PTDEBUG && _d('Before deduping:', join(', ', @candidates)); 2080 my %seen; 2081 @candidates = grep { !$seen{$_}++ } @candidates; 2082 } 2083 PTDEBUG && _d('Final list:', join(', ', @candidates)); 2084 return @candidates; 2085 } 2086 else { 2087 PTDEBUG && _d('No keys in possible_keys'); 2088 return (); 2089 } 2090} 2091 2092sub check_table { 2093 my ( $self, %args ) = @_; 2094 my @required_args = qw(dbh db tbl); 2095 foreach my $arg ( @required_args ) { 2096 die "I need a $arg argument" unless $args{$arg}; 2097 } 2098 my ($dbh, $db, $tbl) = @args{@required_args}; 2099 my $q = $self->{Quoter} || 'Quoter'; 2100 my $db_tbl = $q->quote($db, $tbl); 2101 PTDEBUG && _d('Checking', $db_tbl); 2102 2103 $self->{check_table_error} = undef; 2104 2105 my $sql = "SHOW TABLES FROM " . $q->quote($db) 2106 . ' LIKE ' . $q->literal_like($tbl); 2107 PTDEBUG && _d($sql); 2108 my $row; 2109 eval { 2110 $row = $dbh->selectrow_arrayref($sql); 2111 }; 2112 if ( my $e = $EVAL_ERROR ) { 2113 PTDEBUG && _d($e); 2114 $self->{check_table_error} = $e; 2115 return 0; 2116 } 2117 if ( !$row->[0] || $row->[0] ne $tbl ) { 2118 PTDEBUG && _d('Table does not exist'); 2119 return 0; 2120 } 2121 2122 PTDEBUG && _d('Table', $db, $tbl, 'exists'); 2123 return 1; 2124 2125} 2126 2127sub get_engine { 2128 my ( $self, $ddl, $opts ) = @_; 2129 my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/; 2130 PTDEBUG && _d('Storage engine:', $engine); 2131 return $engine || undef; 2132} 2133 2134sub get_keys { 2135 my ( $self, $ddl, $opts, $is_nullable ) = @_; 2136 my $engine = $self->get_engine($ddl); 2137 my $keys = {}; 2138 my $clustered_key = undef; 2139 2140 KEY: 2141 foreach my $key ( $ddl =~ m/^ ((?:[A-Z]+ )?KEY .*)$/gm ) { 2142 2143 next KEY if $key =~ m/FOREIGN/; 2144 2145 my $key_ddl = $key; 2146 PTDEBUG && _d('Parsed key:', $key_ddl); 2147 2148 if ( !$engine || $engine !~ m/MEMORY|HEAP/ ) { 2149 $key =~ s/USING HASH/USING BTREE/; 2150 } 2151 2152 my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/; 2153 my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/; 2154 $type = $type || $special || 'BTREE'; 2155 my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/; 2156 my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0; 2157 my @cols; 2158 my @col_prefixes; 2159 foreach my $col_def ( $cols =~ m/`[^`]+`(?:\(\d+\))?/g ) { 2160 my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/; 2161 push @cols, $name; 2162 push @col_prefixes, $prefix; 2163 } 2164 $name =~ s/`//g; 2165 2166 PTDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols)); 2167 2168 $keys->{$name} = { 2169 name => $name, 2170 type => $type, 2171 colnames => $cols, 2172 cols => \@cols, 2173 col_prefixes => \@col_prefixes, 2174 is_unique => $unique, 2175 is_nullable => scalar(grep { $is_nullable->{$_} } @cols), 2176 is_col => { map { $_ => 1 } @cols }, 2177 ddl => $key_ddl, 2178 }; 2179 2180 if ( ($engine || '') =~ m/InnoDB/i && !$clustered_key ) { 2181 my $this_key = $keys->{$name}; 2182 if ( $this_key->{name} eq 'PRIMARY' ) { 2183 $clustered_key = 'PRIMARY'; 2184 } 2185 elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) { 2186 $clustered_key = $this_key->{name}; 2187 } 2188 PTDEBUG && $clustered_key && _d('This key is the clustered key'); 2189 } 2190 } 2191 2192 return $keys, $clustered_key; 2193} 2194 2195sub get_fks { 2196 my ( $self, $ddl, $opts ) = @_; 2197 my $q = $self->{Quoter}; 2198 my $fks = {}; 2199 2200 foreach my $fk ( 2201 $ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg ) 2202 { 2203 my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/; 2204 my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/; 2205 my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/; 2206 2207 my ($db, $tbl) = $q->split_unquote($parent, $opts->{database}); 2208 my %parent_tbl = (tbl => $tbl); 2209 $parent_tbl{db} = $db if $db; 2210 2211 if ( $parent !~ m/\./ && $opts->{database} ) { 2212 $parent = $q->quote($opts->{database}) . ".$parent"; 2213 } 2214 2215 $fks->{$name} = { 2216 name => $name, 2217 colnames => $cols, 2218 cols => [ map { s/[ `]+//g; $_; } split(',', $cols) ], 2219 parent_tbl => \%parent_tbl, 2220 parent_tblname => $parent, 2221 parent_cols => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ], 2222 parent_colnames=> $parent_cols, 2223 ddl => $fk, 2224 }; 2225 } 2226 2227 return $fks; 2228} 2229 2230sub remove_auto_increment { 2231 my ( $self, $ddl ) = @_; 2232 $ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m; 2233 return $ddl; 2234} 2235 2236sub get_table_status { 2237 my ( $self, $dbh, $db, $like ) = @_; 2238 my $q = $self->{Quoter}; 2239 my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db); 2240 my @params; 2241 if ( $like ) { 2242 $sql .= ' LIKE ?'; 2243 push @params, $like; 2244 } 2245 PTDEBUG && _d($sql, @params); 2246 my $sth = $dbh->prepare($sql); 2247 eval { $sth->execute(@params); }; 2248 if ($EVAL_ERROR) { 2249 PTDEBUG && _d($EVAL_ERROR); 2250 return; 2251 } 2252 my @tables = @{$sth->fetchall_arrayref({})}; 2253 @tables = map { 2254 my %tbl; # Make a copy with lowercased keys 2255 @tbl{ map { lc $_ } keys %$_ } = values %$_; 2256 $tbl{engine} ||= $tbl{type} || $tbl{comment}; 2257 delete $tbl{type}; 2258 \%tbl; 2259 } @tables; 2260 return @tables; 2261} 2262 2263my $ansi_quote_re = qr/" [^"]* (?: "" [^"]* )* (?<=.) "/ismx; 2264sub ansi_to_legacy { 2265 my ($self, $ddl) = @_; 2266 $ddl =~ s/($ansi_quote_re)/ansi_quote_replace($1)/ge; 2267 return $ddl; 2268} 2269 2270sub ansi_quote_replace { 2271 my ($val) = @_; 2272 $val =~ s/^"|"$//g; 2273 $val =~ s/`/``/g; 2274 $val =~ s/""/"/g; 2275 return "`$val`"; 2276} 2277 2278sub _d { 2279 my ($package, undef, $line) = caller 0; 2280 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 2281 map { defined $_ ? $_ : 'undef' } 2282 @_; 2283 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 2284} 2285 22861; 2287} 2288# ########################################################################### 2289# End TableParser package 2290# ########################################################################### 2291 2292# ########################################################################### 2293# DSNParser package 2294# This package is a copy without comments from the original. The original 2295# with comments and its test file can be found in the Bazaar repository at, 2296# lib/DSNParser.pm 2297# t/lib/DSNParser.t 2298# See https://launchpad.net/percona-toolkit for more information. 2299# ########################################################################### 2300{ 2301package DSNParser; 2302 2303use strict; 2304use warnings FATAL => 'all'; 2305use English qw(-no_match_vars); 2306use constant PTDEBUG => $ENV{PTDEBUG} || 0; 2307 2308use Data::Dumper; 2309$Data::Dumper::Indent = 0; 2310$Data::Dumper::Quotekeys = 0; 2311 2312my $dsn_sep = qr/(?<!\\),/; 2313 2314eval { 2315 require DBI; 2316}; 2317my $have_dbi = $EVAL_ERROR ? 0 : 1; 2318 2319sub new { 2320 my ( $class, %args ) = @_; 2321 foreach my $arg ( qw(opts) ) { 2322 die "I need a $arg argument" unless $args{$arg}; 2323 } 2324 my $self = { 2325 opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD. 2326 }; 2327 foreach my $opt ( @{$args{opts}} ) { 2328 if ( !$opt->{key} || !$opt->{desc} ) { 2329 die "Invalid DSN option: ", Dumper($opt); 2330 } 2331 PTDEBUG && _d('DSN option:', 2332 join(', ', 2333 map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') } 2334 keys %$opt 2335 ) 2336 ); 2337 $self->{opts}->{$opt->{key}} = { 2338 dsn => $opt->{dsn}, 2339 desc => $opt->{desc}, 2340 copy => $opt->{copy} || 0, 2341 }; 2342 } 2343 return bless $self, $class; 2344} 2345 2346sub prop { 2347 my ( $self, $prop, $value ) = @_; 2348 if ( @_ > 2 ) { 2349 PTDEBUG && _d('Setting', $prop, 'property'); 2350 $self->{$prop} = $value; 2351 } 2352 return $self->{$prop}; 2353} 2354 2355sub parse { 2356 my ( $self, $dsn, $prev, $defaults ) = @_; 2357 if ( !$dsn ) { 2358 PTDEBUG && _d('No DSN to parse'); 2359 return; 2360 } 2361 PTDEBUG && _d('Parsing', $dsn); 2362 $prev ||= {}; 2363 $defaults ||= {}; 2364 my %given_props; 2365 my %final_props; 2366 my $opts = $self->{opts}; 2367 2368 foreach my $dsn_part ( split($dsn_sep, $dsn) ) { 2369 $dsn_part =~ s/\\,/,/g; 2370 if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) { 2371 $given_props{$prop_key} = $prop_val; 2372 } 2373 else { 2374 PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part); 2375 $given_props{h} = $dsn_part; 2376 } 2377 } 2378 2379 foreach my $key ( keys %$opts ) { 2380 PTDEBUG && _d('Finding value for', $key); 2381 $final_props{$key} = $given_props{$key}; 2382 if ( !defined $final_props{$key} 2383 && defined $prev->{$key} && $opts->{$key}->{copy} ) 2384 { 2385 $final_props{$key} = $prev->{$key}; 2386 PTDEBUG && _d('Copying value for', $key, 'from previous DSN'); 2387 } 2388 if ( !defined $final_props{$key} ) { 2389 $final_props{$key} = $defaults->{$key}; 2390 PTDEBUG && _d('Copying value for', $key, 'from defaults'); 2391 } 2392 } 2393 2394 foreach my $key ( keys %given_props ) { 2395 die "Unknown DSN option '$key' in '$dsn'. For more details, " 2396 . "please use the --help option, or try 'perldoc $PROGRAM_NAME' " 2397 . "for complete documentation." 2398 unless exists $opts->{$key}; 2399 } 2400 if ( (my $required = $self->prop('required')) ) { 2401 foreach my $key ( keys %$required ) { 2402 die "Missing required DSN option '$key' in '$dsn'. For more details, " 2403 . "please use the --help option, or try 'perldoc $PROGRAM_NAME' " 2404 . "for complete documentation." 2405 unless $final_props{$key}; 2406 } 2407 } 2408 2409 return \%final_props; 2410} 2411 2412sub parse_options { 2413 my ( $self, $o ) = @_; 2414 die 'I need an OptionParser object' unless ref $o eq 'OptionParser'; 2415 my $dsn_string 2416 = join(',', 2417 map { "$_=".$o->get($_); } 2418 grep { $o->has($_) && $o->get($_) } 2419 keys %{$self->{opts}} 2420 ); 2421 PTDEBUG && _d('DSN string made from options:', $dsn_string); 2422 return $self->parse($dsn_string); 2423} 2424 2425sub as_string { 2426 my ( $self, $dsn, $props ) = @_; 2427 return $dsn unless ref $dsn; 2428 my @keys = $props ? @$props : sort keys %$dsn; 2429 return join(',', 2430 map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) } 2431 grep { 2432 exists $self->{opts}->{$_} 2433 && exists $dsn->{$_} 2434 && defined $dsn->{$_} 2435 } @keys); 2436} 2437 2438sub usage { 2439 my ( $self ) = @_; 2440 my $usage 2441 = "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n" 2442 . " KEY COPY MEANING\n" 2443 . " === ==== =============================================\n"; 2444 my %opts = %{$self->{opts}}; 2445 foreach my $key ( sort keys %opts ) { 2446 $usage .= " $key " 2447 . ($opts{$key}->{copy} ? 'yes ' : 'no ') 2448 . ($opts{$key}->{desc} || '[No description]') 2449 . "\n"; 2450 } 2451 $usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n"; 2452 return $usage; 2453} 2454 2455sub get_cxn_params { 2456 my ( $self, $info ) = @_; 2457 my $dsn; 2458 my %opts = %{$self->{opts}}; 2459 my $driver = $self->prop('dbidriver') || ''; 2460 if ( $driver eq 'Pg' ) { 2461 $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';' 2462 . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" } 2463 grep { defined $info->{$_} } 2464 qw(h P)); 2465 } 2466 else { 2467 $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';' 2468 . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" } 2469 grep { defined $info->{$_} } 2470 qw(F h P S A)) 2471 . ';mysql_read_default_group=client' 2472 . ($info->{L} ? ';mysql_local_infile=1' : ''); 2473 } 2474 PTDEBUG && _d($dsn); 2475 return ($dsn, $info->{u}, $info->{p}); 2476} 2477 2478sub fill_in_dsn { 2479 my ( $self, $dbh, $dsn ) = @_; 2480 my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name'); 2481 my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()'); 2482 $user =~ s/@.*//; 2483 $dsn->{h} ||= $vars->{hostname}->{Value}; 2484 $dsn->{S} ||= $vars->{'socket'}->{Value}; 2485 $dsn->{P} ||= $vars->{port}->{Value}; 2486 $dsn->{u} ||= $user; 2487 $dsn->{D} ||= $db; 2488} 2489 2490sub get_dbh { 2491 my ( $self, $cxn_string, $user, $pass, $opts ) = @_; 2492 $opts ||= {}; 2493 my $defaults = { 2494 AutoCommit => 0, 2495 RaiseError => 1, 2496 PrintError => 0, 2497 ShowErrorStatement => 1, 2498 mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0), 2499 }; 2500 @{$defaults}{ keys %$opts } = values %$opts; 2501 if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension 2502 $defaults->{mysql_local_infile} = 1; 2503 } 2504 2505 if ( $opts->{mysql_use_result} ) { 2506 $defaults->{mysql_use_result} = 1; 2507 } 2508 2509 if ( !$have_dbi ) { 2510 die "Cannot connect to MySQL because the Perl DBI module is not " 2511 . "installed or not found. Run 'perl -MDBI' to see the directories " 2512 . "that Perl searches for DBI. If DBI is not installed, try:\n" 2513 . " Debian/Ubuntu apt-get install libdbi-perl\n" 2514 . " RHEL/CentOS yum install perl-DBI\n" 2515 . " OpenSolaris pkg install pkg:/SUNWpmdbi\n"; 2516 2517 } 2518 2519 my $dbh; 2520 my $tries = 2; 2521 while ( !$dbh && $tries-- ) { 2522 PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, 2523 join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults )); 2524 2525 $dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) }; 2526 2527 if ( !$dbh && $EVAL_ERROR ) { 2528 if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) { 2529 die "Cannot connect to MySQL because the Perl DBD::mysql module is " 2530 . "not installed or not found. Run 'perl -MDBD::mysql' to see " 2531 . "the directories that Perl searches for DBD::mysql. If " 2532 . "DBD::mysql is not installed, try:\n" 2533 . " Debian/Ubuntu apt-get install libdbd-mysql-perl\n" 2534 . " RHEL/CentOS yum install perl-DBD-MySQL\n" 2535 . " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n"; 2536 } 2537 elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) { 2538 PTDEBUG && _d('Going to try again without utf8 support'); 2539 delete $defaults->{mysql_enable_utf8}; 2540 } 2541 if ( !$tries ) { 2542 die $EVAL_ERROR; 2543 } 2544 } 2545 } 2546 2547 if ( $cxn_string =~ m/mysql/i ) { 2548 my $sql; 2549 2550 if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) { 2551 $sql = qq{/*!40101 SET NAMES "$charset"*/}; 2552 PTDEBUG && _d($dbh, $sql); 2553 eval { $dbh->do($sql) }; 2554 if ( $EVAL_ERROR ) { 2555 die "Error setting NAMES to $charset: $EVAL_ERROR"; 2556 } 2557 PTDEBUG && _d('Enabling charset for STDOUT'); 2558 if ( $charset eq 'utf8' ) { 2559 binmode(STDOUT, ':utf8') 2560 or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR"; 2561 } 2562 else { 2563 binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR"; 2564 } 2565 } 2566 2567 if ( my $vars = $self->prop('set-vars') ) { 2568 $self->set_vars($dbh, $vars); 2569 } 2570 2571 $sql = 'SELECT @@SQL_MODE'; 2572 PTDEBUG && _d($dbh, $sql); 2573 my ($sql_mode) = eval { $dbh->selectrow_array($sql) }; 2574 if ( $EVAL_ERROR ) { 2575 die "Error getting the current SQL_MODE: $EVAL_ERROR"; 2576 } 2577 2578 $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1' 2579 . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO' 2580 . ($sql_mode ? ",$sql_mode" : '') 2581 . '\'*/'; 2582 PTDEBUG && _d($dbh, $sql); 2583 eval { $dbh->do($sql) }; 2584 if ( $EVAL_ERROR ) { 2585 die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE" 2586 . ($sql_mode ? " and $sql_mode" : '') 2587 . ": $EVAL_ERROR"; 2588 } 2589 } 2590 my ($mysql_version) = eval { $dbh->selectrow_array('SELECT VERSION()') }; 2591 if ($EVAL_ERROR) { 2592 die "Cannot get MySQL version: $EVAL_ERROR"; 2593 } 2594 2595 my (undef, $character_set_server) = eval { $dbh->selectrow_array("SHOW VARIABLES LIKE 'character_set_server'") }; 2596 if ($EVAL_ERROR) { 2597 die "Cannot get MySQL var character_set_server: $EVAL_ERROR"; 2598 } 2599 2600 if ($mysql_version =~ m/^(\d+)\.(\d)\.(\d+).*/) { 2601 if ($1 >= 8 && $character_set_server =~ m/^utf8/) { 2602 $dbh->{mysql_enable_utf8} = 1; 2603 my $msg = "MySQL version $mysql_version >= 8 and character_set_server = $character_set_server\n". 2604 "Setting: SET NAMES $character_set_server"; 2605 PTDEBUG && _d($msg); 2606 eval { $dbh->do("SET NAMES 'utf8mb4'") }; 2607 if ($EVAL_ERROR) { 2608 die "Cannot SET NAMES $character_set_server: $EVAL_ERROR"; 2609 } 2610 } 2611 } 2612 2613 PTDEBUG && _d('DBH info: ', 2614 $dbh, 2615 Dumper($dbh->selectrow_hashref( 2616 'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')), 2617 'Connection info:', $dbh->{mysql_hostinfo}, 2618 'Character set info:', Dumper($dbh->selectall_arrayref( 2619 "SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})), 2620 '$DBD::mysql::VERSION:', $DBD::mysql::VERSION, 2621 '$DBI::VERSION:', $DBI::VERSION, 2622 ); 2623 2624 return $dbh; 2625} 2626 2627sub get_hostname { 2628 my ( $self, $dbh ) = @_; 2629 if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) { 2630 return $host; 2631 } 2632 my ( $hostname, $one ) = $dbh->selectrow_array( 2633 'SELECT /*!50038 @@hostname, */ 1'); 2634 return $hostname; 2635} 2636 2637sub disconnect { 2638 my ( $self, $dbh ) = @_; 2639 PTDEBUG && $self->print_active_handles($dbh); 2640 $dbh->disconnect; 2641} 2642 2643sub print_active_handles { 2644 my ( $self, $thing, $level ) = @_; 2645 $level ||= 0; 2646 printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level, 2647 $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : '')) 2648 or die "Cannot print: $OS_ERROR"; 2649 foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) { 2650 $self->print_active_handles( $handle, $level + 1 ); 2651 } 2652} 2653 2654sub copy { 2655 my ( $self, $dsn_1, $dsn_2, %args ) = @_; 2656 die 'I need a dsn_1 argument' unless $dsn_1; 2657 die 'I need a dsn_2 argument' unless $dsn_2; 2658 my %new_dsn = map { 2659 my $key = $_; 2660 my $val; 2661 if ( $args{overwrite} ) { 2662 $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key}; 2663 } 2664 else { 2665 $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key}; 2666 } 2667 $key => $val; 2668 } keys %{$self->{opts}}; 2669 return \%new_dsn; 2670} 2671 2672sub set_vars { 2673 my ($self, $dbh, $vars) = @_; 2674 2675 return unless $vars; 2676 2677 foreach my $var ( sort keys %$vars ) { 2678 my $val = $vars->{$var}->{val}; 2679 2680 (my $quoted_var = $var) =~ s/_/\\_/; 2681 my ($var_exists, $current_val); 2682 eval { 2683 ($var_exists, $current_val) = $dbh->selectrow_array( 2684 "SHOW VARIABLES LIKE '$quoted_var'"); 2685 }; 2686 my $e = $EVAL_ERROR; 2687 if ( $e ) { 2688 PTDEBUG && _d($e); 2689 } 2690 2691 if ( $vars->{$var}->{default} && !$var_exists ) { 2692 PTDEBUG && _d('Not setting default var', $var, 2693 'because it does not exist'); 2694 next; 2695 } 2696 2697 if ( $current_val && $current_val eq $val ) { 2698 PTDEBUG && _d('Not setting var', $var, 'because its value', 2699 'is already', $val); 2700 next; 2701 } 2702 2703 my $sql = "SET SESSION $var=$val"; 2704 PTDEBUG && _d($dbh, $sql); 2705 eval { $dbh->do($sql) }; 2706 if ( my $set_error = $EVAL_ERROR ) { 2707 chomp($set_error); 2708 $set_error =~ s/ at \S+ line \d+//; 2709 my $msg = "Error setting $var: $set_error"; 2710 if ( $current_val ) { 2711 $msg .= " The current value for $var is $current_val. " 2712 . "If the variable is read only (not dynamic), specify " 2713 . "--set-vars $var=$current_val to avoid this warning, " 2714 . "else manually set the variable and restart MySQL."; 2715 } 2716 warn $msg . "\n\n"; 2717 } 2718 } 2719 2720 return; 2721} 2722 2723sub _d { 2724 my ($package, undef, $line) = caller 0; 2725 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 2726 map { defined $_ ? $_ : 'undef' } 2727 @_; 2728 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 2729} 2730 27311; 2732} 2733# ########################################################################### 2734# End DSNParser package 2735# ########################################################################### 2736 2737# ########################################################################### 2738# VersionParser package 2739# This package is a copy without comments from the original. The original 2740# with comments and its test file can be found in the Bazaar repository at, 2741# lib/VersionParser.pm 2742# t/lib/VersionParser.t 2743# See https://launchpad.net/percona-toolkit for more information. 2744# ########################################################################### 2745{ 2746package VersionParser; 2747 2748use Lmo; 2749use Scalar::Util qw(blessed); 2750use English qw(-no_match_vars); 2751use constant PTDEBUG => $ENV{PTDEBUG} || 0; 2752 2753use overload ( 2754 '""' => "version", 2755 '<=>' => "cmp", 2756 'cmp' => "cmp", 2757 fallback => 1, 2758); 2759 2760use Carp (); 2761 2762our $VERSION = 0.01; 2763 2764has major => ( 2765 is => 'ro', 2766 isa => 'Int', 2767 required => 1, 2768); 2769 2770has [qw( minor revision )] => ( 2771 is => 'ro', 2772 isa => 'Num', 2773); 2774 2775has flavor => ( 2776 is => 'ro', 2777 isa => 'Str', 2778 default => sub { 'Unknown' }, 2779); 2780 2781has innodb_version => ( 2782 is => 'ro', 2783 isa => 'Str', 2784 default => sub { 'NO' }, 2785); 2786 2787sub series { 2788 my $self = shift; 2789 return $self->_join_version($self->major, $self->minor); 2790} 2791 2792sub version { 2793 my $self = shift; 2794 return $self->_join_version($self->major, $self->minor, $self->revision); 2795} 2796 2797sub is_in { 2798 my ($self, $target) = @_; 2799 2800 return $self eq $target; 2801} 2802 2803sub _join_version { 2804 my ($self, @parts) = @_; 2805 2806 return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; 2807} 2808sub _split_version { 2809 my ($self, $str) = @_; 2810 my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; 2811 return @version_parts[0..2]; 2812} 2813 2814sub normalized_version { 2815 my ( $self ) = @_; 2816 my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major, 2817 $self->minor, 2818 $self->revision); 2819 PTDEBUG && _d($self->version, 'normalizes to', $result); 2820 return $result; 2821} 2822 2823sub comment { 2824 my ( $self, $cmd ) = @_; 2825 my $v = $self->normalized_version(); 2826 2827 return "/*!$v $cmd */" 2828} 2829 2830my @methods = qw(major minor revision); 2831sub cmp { 2832 my ($left, $right) = @_; 2833 my $right_obj = (blessed($right) && $right->isa(ref($left))) 2834 ? $right 2835 : ref($left)->new($right); 2836 2837 my $retval = 0; 2838 for my $m ( @methods ) { 2839 last unless defined($left->$m) && defined($right_obj->$m); 2840 $retval = $left->$m <=> $right_obj->$m; 2841 last if $retval; 2842 } 2843 return $retval; 2844} 2845 2846sub BUILDARGS { 2847 my $self = shift; 2848 2849 if ( @_ == 1 ) { 2850 my %args; 2851 if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { 2852 PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); 2853 my $dbh = $_[0]; 2854 local $dbh->{FetchHashKeyName} = 'NAME_lc'; 2855 my $query = eval { 2856 $dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} }) 2857 }; 2858 if ( $query ) { 2859 $query = { map { $_->{variable_name} => $_->{value} } @$query }; 2860 @args{@methods} = $self->_split_version($query->{version}); 2861 $args{flavor} = delete $query->{version_comment} 2862 if $query->{version_comment}; 2863 } 2864 elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) { 2865 @args{@methods} = $self->_split_version($query); 2866 } 2867 else { 2868 Carp::confess("Couldn't get the version from the dbh while " 2869 . "creating a VersionParser object: $@"); 2870 } 2871 $args{innodb_version} = eval { $self->_innodb_version($dbh) }; 2872 } 2873 elsif ( !ref($_[0]) ) { 2874 @args{@methods} = $self->_split_version($_[0]); 2875 } 2876 2877 for my $method (@methods) { 2878 delete $args{$method} unless defined $args{$method}; 2879 } 2880 @_ = %args if %args; 2881 } 2882 2883 return $self->SUPER::BUILDARGS(@_); 2884} 2885 2886sub _innodb_version { 2887 my ( $self, $dbh ) = @_; 2888 return unless $dbh; 2889 my $innodb_version = "NO"; 2890 2891 my ($innodb) = 2892 grep { $_->{engine} =~ m/InnoDB/i } 2893 map { 2894 my %hash; 2895 @hash{ map { lc $_ } keys %$_ } = values %$_; 2896 \%hash; 2897 } 2898 @{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) }; 2899 if ( $innodb ) { 2900 PTDEBUG && _d("InnoDB support:", $innodb->{support}); 2901 if ( $innodb->{support} =~ m/YES|DEFAULT/i ) { 2902 my $vars = $dbh->selectrow_hashref( 2903 "SHOW VARIABLES LIKE 'innodb_version'"); 2904 $innodb_version = !$vars ? "BUILTIN" 2905 : ($vars->{Value} || $vars->{value}); 2906 } 2907 else { 2908 $innodb_version = $innodb->{support}; # probably DISABLED or NO 2909 } 2910 } 2911 2912 PTDEBUG && _d("InnoDB version:", $innodb_version); 2913 return $innodb_version; 2914} 2915 2916sub _d { 2917 my ($package, undef, $line) = caller 0; 2918 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 2919 map { defined $_ ? $_ : 'undef' } 2920 @_; 2921 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 2922} 2923 2924no Lmo; 29251; 2926} 2927# ########################################################################### 2928# End VersionParser package 2929# ########################################################################### 2930 2931# ########################################################################### 2932# Quoter package 2933# This package is a copy without comments from the original. The original 2934# with comments and its test file can be found in the Bazaar repository at, 2935# lib/Quoter.pm 2936# t/lib/Quoter.t 2937# See https://launchpad.net/percona-toolkit for more information. 2938# ########################################################################### 2939{ 2940package Quoter; 2941 2942use strict; 2943use warnings FATAL => 'all'; 2944use English qw(-no_match_vars); 2945use constant PTDEBUG => $ENV{PTDEBUG} || 0; 2946 2947use Data::Dumper; 2948$Data::Dumper::Indent = 1; 2949$Data::Dumper::Sortkeys = 1; 2950$Data::Dumper::Quotekeys = 0; 2951 2952sub new { 2953 my ( $class, %args ) = @_; 2954 return bless {}, $class; 2955} 2956 2957sub quote { 2958 my ( $self, @vals ) = @_; 2959 foreach my $val ( @vals ) { 2960 $val =~ s/`/``/g; 2961 } 2962 return join('.', map { '`' . $_ . '`' } @vals); 2963} 2964 2965sub quote_val { 2966 my ( $self, $val, %args ) = @_; 2967 2968 return 'NULL' unless defined $val; # undef = NULL 2969 return "''" if $val eq ''; # blank string = '' 2970 return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data 2971 && !$args{is_char}; # unless is_char is true 2972 2973 $val =~ s/(['\\])/\\$1/g; 2974 return "'$val'"; 2975} 2976 2977sub split_unquote { 2978 my ( $self, $db_tbl, $default_db ) = @_; 2979 my ( $db, $tbl ) = split(/[.]/, $db_tbl); 2980 if ( !$tbl ) { 2981 $tbl = $db; 2982 $db = $default_db; 2983 } 2984 for ($db, $tbl) { 2985 next unless $_; 2986 s/\A`//; 2987 s/`\z//; 2988 s/``/`/g; 2989 } 2990 2991 return ($db, $tbl); 2992} 2993 2994sub literal_like { 2995 my ( $self, $like ) = @_; 2996 return unless $like; 2997 $like =~ s/([%_])/\\$1/g; 2998 return "'$like'"; 2999} 3000 3001sub join_quote { 3002 my ( $self, $default_db, $db_tbl ) = @_; 3003 return unless $db_tbl; 3004 my ($db, $tbl) = split(/[.]/, $db_tbl); 3005 if ( !$tbl ) { 3006 $tbl = $db; 3007 $db = $default_db; 3008 } 3009 $db = "`$db`" if $db && $db !~ m/^`/; 3010 $tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/; 3011 return $db ? "$db.$tbl" : $tbl; 3012} 3013 3014sub serialize_list { 3015 my ( $self, @args ) = @_; 3016 PTDEBUG && _d('Serializing', Dumper(\@args)); 3017 return unless @args; 3018 3019 my @parts; 3020 foreach my $arg ( @args ) { 3021 if ( defined $arg ) { 3022 $arg =~ s/,/\\,/g; # escape commas 3023 $arg =~ s/\\N/\\\\N/g; # escape literal \N 3024 push @parts, $arg; 3025 } 3026 else { 3027 push @parts, '\N'; 3028 } 3029 } 3030 3031 my $string = join(',', @parts); 3032 PTDEBUG && _d('Serialized: <', $string, '>'); 3033 return $string; 3034} 3035 3036sub deserialize_list { 3037 my ( $self, $string ) = @_; 3038 PTDEBUG && _d('Deserializing <', $string, '>'); 3039 die "Cannot deserialize an undefined string" unless defined $string; 3040 3041 my @parts; 3042 foreach my $arg ( split(/(?<!\\),/, $string) ) { 3043 if ( $arg eq '\N' ) { 3044 $arg = undef; 3045 } 3046 else { 3047 $arg =~ s/\\,/,/g; 3048 $arg =~ s/\\\\N/\\N/g; 3049 } 3050 push @parts, $arg; 3051 } 3052 3053 if ( !@parts ) { 3054 my $n_empty_strings = $string =~ tr/,//; 3055 $n_empty_strings++; 3056 PTDEBUG && _d($n_empty_strings, 'empty strings'); 3057 map { push @parts, '' } 1..$n_empty_strings; 3058 } 3059 elsif ( $string =~ m/(?<!\\),$/ ) { 3060 PTDEBUG && _d('Last value is an empty string'); 3061 push @parts, ''; 3062 } 3063 3064 PTDEBUG && _d('Deserialized', Dumper(\@parts)); 3065 return @parts; 3066} 3067 3068sub _d { 3069 my ($package, undef, $line) = caller 0; 3070 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 3071 map { defined $_ ? $_ : 'undef' } 3072 @_; 3073 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 3074} 3075 30761; 3077} 3078# ########################################################################### 3079# End Quoter package 3080# ########################################################################### 3081 3082# ########################################################################### 3083# TableNibbler package 3084# This package is a copy without comments from the original. The original 3085# with comments and its test file can be found in the Bazaar repository at, 3086# lib/TableNibbler.pm 3087# t/lib/TableNibbler.t 3088# See https://launchpad.net/percona-toolkit for more information. 3089# ########################################################################### 3090{ 3091package TableNibbler; 3092 3093use strict; 3094use warnings FATAL => 'all'; 3095use English qw(-no_match_vars); 3096use constant PTDEBUG => $ENV{PTDEBUG} || 0; 3097 3098sub new { 3099 my ( $class, %args ) = @_; 3100 my @required_args = qw(TableParser Quoter); 3101 foreach my $arg ( @required_args ) { 3102 die "I need a $arg argument" unless $args{$arg}; 3103 } 3104 my $self = { %args }; 3105 return bless $self, $class; 3106} 3107 3108sub generate_asc_stmt { 3109 my ( $self, %args ) = @_; 3110 my @required_args = qw(tbl_struct index); 3111 foreach my $arg ( @required_args ) { 3112 die "I need a $arg argument" unless defined $args{$arg}; 3113 } 3114 my ($tbl_struct, $index) = @args{@required_args}; 3115 my @cols = $args{cols} ? @{$args{cols}} : @{$tbl_struct->{cols}}; 3116 my $q = $self->{Quoter}; 3117 3118 die "Index '$index' does not exist in table" 3119 unless exists $tbl_struct->{keys}->{$index}; 3120 PTDEBUG && _d('Will ascend index', $index); 3121 3122 my @asc_cols = @{$tbl_struct->{keys}->{$index}->{cols}}; 3123 if ( $args{asc_first} ) { 3124 PTDEBUG && _d('Ascending only first column'); 3125 @asc_cols = $asc_cols[0]; 3126 } 3127 elsif ( my $n = $args{n_index_cols} ) { 3128 $n = scalar @asc_cols if $n > @asc_cols; 3129 PTDEBUG && _d('Ascending only first', $n, 'columns'); 3130 @asc_cols = @asc_cols[0..($n-1)]; 3131 } 3132 PTDEBUG && _d('Will ascend columns', join(', ', @asc_cols)); 3133 3134 my @asc_slice; 3135 my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols }; 3136 foreach my $col ( @asc_cols ) { 3137 if ( !exists $col_posn{$col} ) { 3138 push @cols, $col; 3139 $col_posn{$col} = $#cols; 3140 } 3141 push @asc_slice, $col_posn{$col}; 3142 } 3143 PTDEBUG && _d('Will ascend, in ordinal position:', join(', ', @asc_slice)); 3144 3145 my $asc_stmt = { 3146 cols => \@cols, 3147 index => $index, 3148 where => '', 3149 slice => [], 3150 scols => [], 3151 }; 3152 3153 if ( @asc_slice ) { 3154 my $cmp_where; 3155 foreach my $cmp ( qw(< <= >= >) ) { 3156 $cmp_where = $self->generate_cmp_where( 3157 type => $cmp, 3158 slice => \@asc_slice, 3159 cols => \@cols, 3160 quoter => $q, 3161 is_nullable => $tbl_struct->{is_nullable}, 3162 type_for => $tbl_struct->{type_for}, 3163 ); 3164 $asc_stmt->{boundaries}->{$cmp} = $cmp_where->{where}; 3165 } 3166 my $cmp = $args{asc_only} ? '>' : '>='; 3167 $asc_stmt->{where} = $asc_stmt->{boundaries}->{$cmp}; 3168 $asc_stmt->{slice} = $cmp_where->{slice}; 3169 $asc_stmt->{scols} = $cmp_where->{scols}; 3170 } 3171 3172 return $asc_stmt; 3173} 3174 3175sub generate_cmp_where { 3176 my ( $self, %args ) = @_; 3177 foreach my $arg ( qw(type slice cols is_nullable) ) { 3178 die "I need a $arg arg" unless defined $args{$arg}; 3179 } 3180 my @slice = @{$args{slice}}; 3181 my @cols = @{$args{cols}}; 3182 my $is_nullable = $args{is_nullable}; 3183 my $type_for = $args{type_for}; 3184 my $type = $args{type}; 3185 my $q = $self->{Quoter}; 3186 3187 (my $cmp = $type) =~ s/=//; 3188 3189 my @r_slice; # Resulting slice columns, by ordinal 3190 my @r_scols; # Ditto, by name 3191 3192 my @clauses; 3193 foreach my $i ( 0 .. $#slice ) { 3194 my @clause; 3195 3196 foreach my $j ( 0 .. $i - 1 ) { 3197 my $ord = $slice[$j]; 3198 my $col = $cols[$ord]; 3199 my $quo = $q->quote($col); 3200 my $val = ($col && ($type_for->{$col} || '')) eq 'enum' ? "CAST(? AS UNSIGNED)" : "?"; 3201 if ( $is_nullable->{$col} ) { 3202 push @clause, "(($val IS NULL AND $quo IS NULL) OR ($quo = $val))"; 3203 push @r_slice, $ord, $ord; 3204 push @r_scols, $col, $col; 3205 } 3206 else { 3207 push @clause, "$quo = $val"; 3208 push @r_slice, $ord; 3209 push @r_scols, $col; 3210 } 3211 } 3212 3213 my $ord = $slice[$i]; 3214 my $col = $cols[$ord]; 3215 my $quo = $q->quote($col); 3216 my $end = $i == $#slice; # Last clause of the whole group. 3217 my $val = ($col && ($type_for->{$col} || '')) eq 'enum' ? "CAST(? AS UNSIGNED)" : "?"; 3218 if ( $is_nullable->{$col} ) { 3219 if ( $type =~ m/=/ && $end ) { 3220 push @clause, "($val IS NULL OR $quo $type $val)"; 3221 } 3222 elsif ( $type =~ m/>/ ) { 3223 push @clause, "($val IS NULL AND $quo IS NOT NULL) OR ($quo $cmp $val)"; 3224 } 3225 else { # If $type =~ m/</ ) { 3226 push @clauses, "(($val IS NOT NULL AND $quo IS NULL) OR ($quo $cmp $val))"; 3227 } 3228 push @r_slice, $ord, $ord; 3229 push @r_scols, $col, $col; 3230 } 3231 else { 3232 push @r_slice, $ord; 3233 push @r_scols, $col; 3234 push @clause, ($type =~ m/=/ && $end ? "$quo $type $val" : "$quo $cmp $val"); 3235 } 3236 3237 push @clauses, '(' . join(' AND ', @clause) . ')' if @clause; 3238 } 3239 my $result = '(' . join(' OR ', @clauses) . ')'; 3240 my $where = { 3241 slice => \@r_slice, 3242 scols => \@r_scols, 3243 where => $result, 3244 }; 3245 return $where; 3246} 3247 3248sub generate_del_stmt { 3249 my ( $self, %args ) = @_; 3250 3251 my $tbl = $args{tbl_struct}; 3252 my @cols = $args{cols} ? @{$args{cols}} : (); 3253 my $tp = $self->{TableParser}; 3254 my $q = $self->{Quoter}; 3255 3256 my @del_cols; 3257 my @del_slice; 3258 3259 my $index = $tp->find_best_index($tbl, $args{index}); 3260 die "Cannot find an ascendable index in table" unless $index; 3261 3262 if ( $index && $tbl->{keys}->{$index}->{is_unique}) { 3263 @del_cols = @{$tbl->{keys}->{$index}->{cols}}; 3264 } 3265 else { 3266 @del_cols = @{$tbl->{cols}}; 3267 } 3268 PTDEBUG && _d('Columns needed for DELETE:', join(', ', @del_cols)); 3269 3270 my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols }; 3271 foreach my $col ( @del_cols ) { 3272 if ( !exists $col_posn{$col} ) { 3273 push @cols, $col; 3274 $col_posn{$col} = $#cols; 3275 } 3276 push @del_slice, $col_posn{$col}; 3277 } 3278 PTDEBUG && _d('Ordinals needed for DELETE:', join(', ', @del_slice)); 3279 3280 my $del_stmt = { 3281 cols => \@cols, 3282 index => $index, 3283 where => '', 3284 slice => [], 3285 scols => [], 3286 }; 3287 3288 my @clauses; 3289 foreach my $i ( 0 .. $#del_slice ) { 3290 my $ord = $del_slice[$i]; 3291 my $col = $cols[$ord]; 3292 my $quo = $q->quote($col); 3293 if ( $tbl->{is_nullable}->{$col} ) { 3294 push @clauses, "((? IS NULL AND $quo IS NULL) OR ($quo = ?))"; 3295 push @{$del_stmt->{slice}}, $ord, $ord; 3296 push @{$del_stmt->{scols}}, $col, $col; 3297 } 3298 else { 3299 push @clauses, "$quo = ?"; 3300 push @{$del_stmt->{slice}}, $ord; 3301 push @{$del_stmt->{scols}}, $col; 3302 } 3303 } 3304 3305 $del_stmt->{where} = '(' . join(' AND ', @clauses) . ')'; 3306 3307 return $del_stmt; 3308} 3309 3310sub generate_ins_stmt { 3311 my ( $self, %args ) = @_; 3312 foreach my $arg ( qw(ins_tbl sel_cols) ) { 3313 die "I need a $arg argument" unless $args{$arg}; 3314 } 3315 my $ins_tbl = $args{ins_tbl}; 3316 my @sel_cols = @{$args{sel_cols}}; 3317 3318 die "You didn't specify any SELECT columns" unless @sel_cols; 3319 3320 my @ins_cols; 3321 my @ins_slice; 3322 for my $i ( 0..$#sel_cols ) { 3323 next unless $ins_tbl->{is_col}->{$sel_cols[$i]}; 3324 push @ins_cols, $sel_cols[$i]; 3325 push @ins_slice, $i; 3326 } 3327 3328 return { 3329 cols => \@ins_cols, 3330 slice => \@ins_slice, 3331 }; 3332} 3333 3334sub _d { 3335 my ($package, undef, $line) = caller 0; 3336 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 3337 map { defined $_ ? $_ : 'undef' } 3338 @_; 3339 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 3340} 3341 33421; 3343} 3344# ########################################################################### 3345# End TableNibbler package 3346# ########################################################################### 3347 3348# ########################################################################### 3349# Daemon package 3350# This package is a copy without comments from the original. The original 3351# with comments and its test file can be found in the Bazaar repository at, 3352# lib/Daemon.pm 3353# t/lib/Daemon.t 3354# See https://launchpad.net/percona-toolkit for more information. 3355# ########################################################################### 3356{ 3357package Daemon; 3358 3359use strict; 3360use warnings FATAL => 'all'; 3361use English qw(-no_match_vars); 3362use constant PTDEBUG => $ENV{PTDEBUG} || 0; 3363 3364use POSIX qw(setsid); 3365 3366sub new { 3367 my ( $class, %args ) = @_; 3368 foreach my $arg ( qw(o) ) { 3369 die "I need a $arg argument" unless $args{$arg}; 3370 } 3371 my $o = $args{o}; 3372 my $self = { 3373 o => $o, 3374 log_file => $o->has('log') ? $o->get('log') : undef, 3375 PID_file => $o->has('pid') ? $o->get('pid') : undef, 3376 }; 3377 3378 check_PID_file(undef, $self->{PID_file}); 3379 3380 PTDEBUG && _d('Daemonized child will log to', $self->{log_file}); 3381 return bless $self, $class; 3382} 3383 3384sub daemonize { 3385 my ( $self ) = @_; 3386 3387 PTDEBUG && _d('About to fork and daemonize'); 3388 defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR"; 3389 if ( $pid ) { 3390 PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid); 3391 exit; 3392 } 3393 3394 PTDEBUG && _d('Daemonizing child PID', $PID); 3395 $self->{PID_owner} = $PID; 3396 $self->{child} = 1; 3397 3398 POSIX::setsid() or die "Cannot start a new session: $OS_ERROR"; 3399 chdir '/' or die "Cannot chdir to /: $OS_ERROR"; 3400 3401 $self->_make_PID_file(); 3402 3403 $OUTPUT_AUTOFLUSH = 1; 3404 3405 PTDEBUG && _d('Redirecting STDIN to /dev/null'); 3406 close STDIN; 3407 open STDIN, '/dev/null' 3408 or die "Cannot reopen STDIN to /dev/null: $OS_ERROR"; 3409 3410 if ( $self->{log_file} ) { 3411 PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file}); 3412 close STDOUT; 3413 open STDOUT, '>>', $self->{log_file} 3414 or die "Cannot open log file $self->{log_file}: $OS_ERROR"; 3415 3416 close STDERR; 3417 open STDERR, ">&STDOUT" 3418 or die "Cannot dupe STDERR to STDOUT: $OS_ERROR"; 3419 } 3420 else { 3421 if ( -t STDOUT ) { 3422 PTDEBUG && _d('No log file and STDOUT is a terminal;', 3423 'redirecting to /dev/null'); 3424 close STDOUT; 3425 open STDOUT, '>', '/dev/null' 3426 or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR"; 3427 } 3428 if ( -t STDERR ) { 3429 PTDEBUG && _d('No log file and STDERR is a terminal;', 3430 'redirecting to /dev/null'); 3431 close STDERR; 3432 open STDERR, '>', '/dev/null' 3433 or die "Cannot reopen STDERR to /dev/null: $OS_ERROR"; 3434 } 3435 } 3436 3437 return; 3438} 3439 3440sub check_PID_file { 3441 my ( $self, $file ) = @_; 3442 my $PID_file = $self ? $self->{PID_file} : $file; 3443 PTDEBUG && _d('Checking PID file', $PID_file); 3444 if ( $PID_file && -f $PID_file ) { 3445 my $pid; 3446 eval { 3447 chomp($pid = (slurp_file($PID_file) || '')); 3448 }; 3449 if ( $EVAL_ERROR ) { 3450 die "The PID file $PID_file already exists but it cannot be read: " 3451 . $EVAL_ERROR; 3452 } 3453 PTDEBUG && _d('PID file exists; it contains PID', $pid); 3454 if ( $pid ) { 3455 my $pid_is_alive = kill 0, $pid; 3456 if ( $pid_is_alive ) { 3457 die "The PID file $PID_file already exists " 3458 . " and the PID that it contains, $pid, is running"; 3459 } 3460 else { 3461 warn "Overwriting PID file $PID_file because the PID that it " 3462 . "contains, $pid, is not running"; 3463 } 3464 } 3465 else { 3466 die "The PID file $PID_file already exists but it does not " 3467 . "contain a PID"; 3468 } 3469 } 3470 else { 3471 PTDEBUG && _d('No PID file'); 3472 } 3473 return; 3474} 3475 3476sub make_PID_file { 3477 my ( $self ) = @_; 3478 if ( exists $self->{child} ) { 3479 die "Do not call Daemon::make_PID_file() for daemonized scripts"; 3480 } 3481 $self->_make_PID_file(); 3482 $self->{PID_owner} = $PID; 3483 return; 3484} 3485 3486sub _make_PID_file { 3487 my ( $self ) = @_; 3488 3489 my $PID_file = $self->{PID_file}; 3490 if ( !$PID_file ) { 3491 PTDEBUG && _d('No PID file to create'); 3492 return; 3493 } 3494 3495 $self->check_PID_file(); 3496 3497 open my $PID_FH, '>', $PID_file 3498 or die "Cannot open PID file $PID_file: $OS_ERROR"; 3499 print $PID_FH $PID 3500 or die "Cannot print to PID file $PID_file: $OS_ERROR"; 3501 close $PID_FH 3502 or die "Cannot close PID file $PID_file: $OS_ERROR"; 3503 3504 PTDEBUG && _d('Created PID file:', $self->{PID_file}); 3505 return; 3506} 3507 3508sub _remove_PID_file { 3509 my ( $self ) = @_; 3510 if ( $self->{PID_file} && -f $self->{PID_file} ) { 3511 unlink $self->{PID_file} 3512 or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR"; 3513 PTDEBUG && _d('Removed PID file'); 3514 } 3515 else { 3516 PTDEBUG && _d('No PID to remove'); 3517 } 3518 return; 3519} 3520 3521sub DESTROY { 3522 my ( $self ) = @_; 3523 3524 $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID; 3525 3526 return; 3527} 3528 3529sub slurp_file { 3530 my ($file) = @_; 3531 return unless $file; 3532 open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 3533 return do { local $/; <$fh> }; 3534} 3535 3536sub _d { 3537 my ($package, undef, $line) = caller 0; 3538 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 3539 map { defined $_ ? $_ : 'undef' } 3540 @_; 3541 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 3542} 3543 35441; 3545} 3546# ########################################################################### 3547# End Daemon package 3548# ########################################################################### 3549 3550# ########################################################################### 3551# MasterSlave package 3552# This package is a copy without comments from the original. The original 3553# with comments and its test file can be found in the Bazaar repository at, 3554# lib/MasterSlave.pm 3555# t/lib/MasterSlave.t 3556# See https://launchpad.net/percona-toolkit for more information. 3557# ########################################################################### 3558{ 3559package MasterSlave; 3560 3561use strict; 3562use warnings FATAL => 'all'; 3563use English qw(-no_match_vars); 3564use constant PTDEBUG => $ENV{PTDEBUG} || 0; 3565 3566sub check_recursion_method { 3567 my ($methods) = @_; 3568 if ( @$methods != 1 ) { 3569 if ( grep({ !m/processlist|hosts/i } @$methods) 3570 && $methods->[0] !~ /^dsn=/i ) 3571 { 3572 die "Invalid combination of recursion methods: " 3573 . join(", ", map { defined($_) ? $_ : 'undef' } @$methods) . ". " 3574 . "Only hosts and processlist may be combined.\n" 3575 } 3576 } 3577 else { 3578 my ($method) = @$methods; 3579 die "Invalid recursion method: " . ( $method || 'undef' ) 3580 unless $method && $method =~ m/^(?:processlist$|hosts$|none$|cluster$|dsn=)/i; 3581 } 3582} 3583 3584sub new { 3585 my ( $class, %args ) = @_; 3586 my @required_args = qw(OptionParser DSNParser Quoter); 3587 foreach my $arg ( @required_args ) { 3588 die "I need a $arg argument" unless $args{$arg}; 3589 } 3590 my $self = { 3591 %args, 3592 replication_thread => {}, 3593 }; 3594 return bless $self, $class; 3595} 3596 3597sub get_slaves { 3598 my ($self, %args) = @_; 3599 my @required_args = qw(make_cxn); 3600 foreach my $arg ( @required_args ) { 3601 die "I need a $arg argument" unless $args{$arg}; 3602 } 3603 my ($make_cxn) = @args{@required_args}; 3604 3605 my $slaves = []; 3606 my $dp = $self->{DSNParser}; 3607 my $methods = $self->_resolve_recursion_methods($args{dsn}); 3608 3609 return $slaves unless @$methods; 3610 3611 if ( grep { m/processlist|hosts/i } @$methods ) { 3612 my @required_args = qw(dbh dsn); 3613 foreach my $arg ( @required_args ) { 3614 die "I need a $arg argument" unless $args{$arg}; 3615 } 3616 my ($dbh, $dsn) = @args{@required_args}; 3617 my $o = $self->{OptionParser}; 3618 3619 $self->recurse_to_slaves( 3620 { dbh => $dbh, 3621 dsn => $dsn, 3622 slave_user => $o->got('slave-user') ? $o->get('slave-user') : '', 3623 slave_password => $o->got('slave-password') ? $o->get('slave-password') : '', 3624 callback => sub { 3625 my ( $dsn, $dbh, $level, $parent ) = @_; 3626 return unless $level; 3627 PTDEBUG && _d('Found slave:', $dp->as_string($dsn)); 3628 my $slave_dsn = $dsn; 3629 if ($o->got('slave-user')) { 3630 $slave_dsn->{u} = $o->get('slave-user'); 3631 PTDEBUG && _d("Using slave user ".$o->get('slave-user')." on ".$slave_dsn->{h}.":".$slave_dsn->{P}); 3632 } 3633 if ($o->got('slave-password')) { 3634 $slave_dsn->{p} = $o->get('slave-password'); 3635 PTDEBUG && _d("Slave password set"); 3636 } 3637 push @$slaves, $make_cxn->(dsn => $slave_dsn, dbh => $dbh); 3638 return; 3639 }, 3640 } 3641 ); 3642 } elsif ( $methods->[0] =~ m/^dsn=/i ) { 3643 (my $dsn_table_dsn = join ",", @$methods) =~ s/^dsn=//i; 3644 $slaves = $self->get_cxn_from_dsn_table( 3645 %args, 3646 dsn_table_dsn => $dsn_table_dsn, 3647 ); 3648 } 3649 elsif ( $methods->[0] =~ m/none/i ) { 3650 PTDEBUG && _d('Not getting to slaves'); 3651 } 3652 else { 3653 die "Unexpected recursion methods: @$methods"; 3654 } 3655 3656 return $slaves; 3657} 3658 3659sub _resolve_recursion_methods { 3660 my ($self, $dsn) = @_; 3661 my $o = $self->{OptionParser}; 3662 if ( $o->got('recursion-method') ) { 3663 return $o->get('recursion-method'); 3664 } 3665 elsif ( $dsn && ($dsn->{P} || 3306) != 3306 ) { 3666 PTDEBUG && _d('Port number is non-standard; using only hosts method'); 3667 return [qw(hosts)]; 3668 } 3669 else { 3670 return $o->get('recursion-method'); 3671 } 3672} 3673 3674sub recurse_to_slaves { 3675 my ( $self, $args, $level ) = @_; 3676 $level ||= 0; 3677 my $dp = $self->{DSNParser}; 3678 my $recurse = $args->{recurse} || $self->{OptionParser}->get('recurse'); 3679 my $dsn = $args->{dsn}; 3680 my $slave_user = $args->{slave_user} || ''; 3681 my $slave_password = $args->{slave_password} || ''; 3682 3683 my $methods = $self->_resolve_recursion_methods($dsn); 3684 PTDEBUG && _d('Recursion methods:', @$methods); 3685 if ( lc($methods->[0]) eq 'none' ) { 3686 PTDEBUG && _d('Not recursing to slaves'); 3687 return; 3688 } 3689 3690 my $slave_dsn = $dsn; 3691 if ($slave_user) { 3692 $slave_dsn->{u} = $slave_user; 3693 PTDEBUG && _d("Using slave user $slave_user on ".$slave_dsn->{h}.":".$slave_dsn->{P}); 3694 } 3695 if ($slave_password) { 3696 $slave_dsn->{p} = $slave_password; 3697 PTDEBUG && _d("Slave password set"); 3698 } 3699 3700 my $dbh; 3701 eval { 3702 $dbh = $args->{dbh} || $dp->get_dbh( 3703 $dp->get_cxn_params($slave_dsn), { AutoCommit => 1 }); 3704 PTDEBUG && _d('Connected to', $dp->as_string($slave_dsn)); 3705 }; 3706 if ( $EVAL_ERROR ) { 3707 print STDERR "Cannot connect to ", $dp->as_string($slave_dsn), "\n" 3708 or die "Cannot print: $OS_ERROR"; 3709 return; 3710 } 3711 3712 my $sql = 'SELECT @@SERVER_ID'; 3713 PTDEBUG && _d($sql); 3714 my ($id) = $dbh->selectrow_array($sql); 3715 PTDEBUG && _d('Working on server ID', $id); 3716 my $master_thinks_i_am = $dsn->{server_id}; 3717 if ( !defined $id 3718 || ( defined $master_thinks_i_am && $master_thinks_i_am != $id ) 3719 || $args->{server_ids_seen}->{$id}++ 3720 ) { 3721 PTDEBUG && _d('Server ID seen, or not what master said'); 3722 if ( $args->{skip_callback} ) { 3723 $args->{skip_callback}->($dsn, $dbh, $level, $args->{parent}); 3724 } 3725 return; 3726 } 3727 3728 $args->{callback}->($dsn, $dbh, $level, $args->{parent}); 3729 3730 if ( !defined $recurse || $level < $recurse ) { 3731 3732 my @slaves = 3733 grep { !$_->{master_id} || $_->{master_id} == $id } # Only my slaves. 3734 $self->find_slave_hosts($dp, $dbh, $dsn, $methods); 3735 3736 foreach my $slave ( @slaves ) { 3737 PTDEBUG && _d('Recursing from', 3738 $dp->as_string($dsn), 'to', $dp->as_string($slave)); 3739 $self->recurse_to_slaves( 3740 { %$args, dsn => $slave, dbh => undef, parent => $dsn, slave_user => $slave_user, $slave_password => $slave_password }, $level + 1 ); 3741 } 3742 } 3743} 3744 3745sub find_slave_hosts { 3746 my ( $self, $dsn_parser, $dbh, $dsn, $methods ) = @_; 3747 3748 PTDEBUG && _d('Looking for slaves on', $dsn_parser->as_string($dsn), 3749 'using methods', @$methods); 3750 3751 my @slaves; 3752 METHOD: 3753 foreach my $method ( @$methods ) { 3754 my $find_slaves = "_find_slaves_by_$method"; 3755 PTDEBUG && _d('Finding slaves with', $find_slaves); 3756 @slaves = $self->$find_slaves($dsn_parser, $dbh, $dsn); 3757 last METHOD if @slaves; 3758 } 3759 3760 PTDEBUG && _d('Found', scalar(@slaves), 'slaves'); 3761 return @slaves; 3762} 3763 3764sub _find_slaves_by_processlist { 3765 my ( $self, $dsn_parser, $dbh, $dsn ) = @_; 3766 my @connected_slaves = $self->get_connected_slaves($dbh); 3767 my @slaves = $self->_process_slaves_list($dsn_parser, $dsn, \@connected_slaves); 3768 return @slaves; 3769} 3770 3771sub _process_slaves_list { 3772 my ($self, $dsn_parser, $dsn, $connected_slaves) = @_; 3773 my @slaves = map { 3774 my $slave = $dsn_parser->parse("h=$_", $dsn); 3775 $slave->{source} = 'processlist'; 3776 $slave; 3777 } 3778 grep { $_ } 3779 map { 3780 my ( $host ) = $_->{host} =~ m/^(.*):\d+$/; 3781 if ( $host eq 'localhost' ) { 3782 $host = '127.0.0.1'; # Replication never uses sockets. 3783 } 3784 if ($host =~ m/::/) { 3785 $host = '['.$host.']'; 3786 } 3787 $host; 3788 } @$connected_slaves; 3789 3790 return @slaves; 3791} 3792 3793sub _find_slaves_by_hosts { 3794 my ( $self, $dsn_parser, $dbh, $dsn ) = @_; 3795 3796 my @slaves; 3797 my $sql = 'SHOW SLAVE HOSTS'; 3798 PTDEBUG && _d($dbh, $sql); 3799 @slaves = @{$dbh->selectall_arrayref($sql, { Slice => {} })}; 3800 3801 if ( @slaves ) { 3802 PTDEBUG && _d('Found some SHOW SLAVE HOSTS info'); 3803 @slaves = map { 3804 my %hash; 3805 @hash{ map { lc $_ } keys %$_ } = values %$_; 3806 my $spec = "h=$hash{host},P=$hash{port}" 3807 . ( $hash{user} ? ",u=$hash{user}" : '') 3808 . ( $hash{password} ? ",p=$hash{password}" : ''); 3809 my $dsn = $dsn_parser->parse($spec, $dsn); 3810 $dsn->{server_id} = $hash{server_id}; 3811 $dsn->{master_id} = $hash{master_id}; 3812 $dsn->{source} = 'hosts'; 3813 $dsn; 3814 } @slaves; 3815 } 3816 3817 return @slaves; 3818} 3819 3820sub get_connected_slaves { 3821 my ( $self, $dbh ) = @_; 3822 3823 my $show = "SHOW GRANTS FOR "; 3824 my $user = 'CURRENT_USER()'; 3825 my $sql = $show . $user; 3826 PTDEBUG && _d($dbh, $sql); 3827 3828 my $proc; 3829 eval { 3830 $proc = grep { 3831 m/ALL PRIVILEGES.*?\*\.\*|PROCESS/ 3832 } @{$dbh->selectcol_arrayref($sql)}; 3833 }; 3834 if ( $EVAL_ERROR ) { 3835 3836 if ( $EVAL_ERROR =~ m/no such grant defined for user/ ) { 3837 PTDEBUG && _d('Retrying SHOW GRANTS without host; error:', 3838 $EVAL_ERROR); 3839 ($user) = split('@', $user); 3840 $sql = $show . $user; 3841 PTDEBUG && _d($sql); 3842 eval { 3843 $proc = grep { 3844 m/ALL PRIVILEGES.*?\*\.\*|PROCESS/ 3845 } @{$dbh->selectcol_arrayref($sql)}; 3846 }; 3847 } 3848 3849 die "Failed to $sql: $EVAL_ERROR" if $EVAL_ERROR; 3850 } 3851 if ( !$proc ) { 3852 die "You do not have the PROCESS privilege"; 3853 } 3854 3855 $sql = 'SHOW FULL PROCESSLIST'; 3856 PTDEBUG && _d($dbh, $sql); 3857 grep { $_->{command} =~ m/Binlog Dump/i } 3858 map { # Lowercase the column names 3859 my %hash; 3860 @hash{ map { lc $_ } keys %$_ } = values %$_; 3861 \%hash; 3862 } 3863 @{$dbh->selectall_arrayref($sql, { Slice => {} })}; 3864} 3865 3866sub is_master_of { 3867 my ( $self, $master, $slave ) = @_; 3868 my $master_status = $self->get_master_status($master) 3869 or die "The server specified as a master is not a master"; 3870 my $slave_status = $self->get_slave_status($slave) 3871 or die "The server specified as a slave is not a slave"; 3872 my @connected = $self->get_connected_slaves($master) 3873 or die "The server specified as a master has no connected slaves"; 3874 my (undef, $port) = $master->selectrow_array("SHOW VARIABLES LIKE 'port'"); 3875 3876 if ( $port != $slave_status->{master_port} ) { 3877 die "The slave is connected to $slave_status->{master_port} " 3878 . "but the master's port is $port"; 3879 } 3880 3881 if ( !grep { $slave_status->{master_user} eq $_->{user} } @connected ) { 3882 die "I don't see any slave I/O thread connected with user " 3883 . $slave_status->{master_user}; 3884 } 3885 3886 if ( ($slave_status->{slave_io_state} || '') 3887 eq 'Waiting for master to send event' ) 3888 { 3889 my ( $master_log_name, $master_log_num ) 3890 = $master_status->{file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/; 3891 my ( $slave_log_name, $slave_log_num ) 3892 = $slave_status->{master_log_file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/; 3893 if ( $master_log_name ne $slave_log_name 3894 || abs($master_log_num - $slave_log_num) > 1 ) 3895 { 3896 die "The slave thinks it is reading from " 3897 . "$slave_status->{master_log_file}, but the " 3898 . "master is writing to $master_status->{file}"; 3899 } 3900 } 3901 return 1; 3902} 3903 3904sub get_master_dsn { 3905 my ( $self, $dbh, $dsn, $dsn_parser ) = @_; 3906 my $master = $self->get_slave_status($dbh) or return undef; 3907 my $spec = "h=$master->{master_host},P=$master->{master_port}"; 3908 return $dsn_parser->parse($spec, $dsn); 3909} 3910 3911sub get_slave_status { 3912 my ( $self, $dbh ) = @_; 3913 3914 if ( !$self->{not_a_slave}->{$dbh} ) { 3915 my $sth = $self->{sths}->{$dbh}->{SLAVE_STATUS} 3916 ||= $dbh->prepare('SHOW SLAVE STATUS'); 3917 PTDEBUG && _d($dbh, 'SHOW SLAVE STATUS'); 3918 $sth->execute(); 3919 my ($sss_rows) = $sth->fetchall_arrayref({}); # Show Slave Status rows 3920 3921 my $ss; 3922 if ( $sss_rows && @$sss_rows ) { 3923 if (scalar @$sss_rows > 1) { 3924 if (!$self->{channel}) { 3925 die 'This server returned more than one row for SHOW SLAVE STATUS but "channel" was not specified on the command line'; 3926 } 3927 my $slave_use_channels; 3928 for my $row (@$sss_rows) { 3929 $row = { map { lc($_) => $row->{$_} } keys %$row }; # lowercase the keys 3930 if ($row->{channel_name}) { 3931 $slave_use_channels = 1; 3932 } 3933 if ($row->{channel_name} eq $self->{channel}) { 3934 $ss = $row; 3935 last; 3936 } 3937 } 3938 if (!$ss && $slave_use_channels) { 3939 die 'This server is using replication channels but "channel" was not specified on the command line'; 3940 } 3941 } else { 3942 if ($sss_rows->[0]->{channel_name} && $sss_rows->[0]->{channel_name} ne $self->{channel}) { 3943 die 'This server is using replication channels but "channel" was not specified on the command line'; 3944 } else { 3945 $ss = $sss_rows->[0]; 3946 } 3947 } 3948 3949 if ( $ss && %$ss ) { 3950 $ss = { map { lc($_) => $ss->{$_} } keys %$ss }; # lowercase the keys 3951 return $ss; 3952 } 3953 if (!$ss && $self->{channel}) { 3954 die "Specified channel name is invalid"; 3955 } 3956 } 3957 3958 PTDEBUG && _d('This server returns nothing for SHOW SLAVE STATUS'); 3959 $self->{not_a_slave}->{$dbh}++; 3960 } 3961} 3962 3963sub get_master_status { 3964 my ( $self, $dbh ) = @_; 3965 3966 if ( $self->{not_a_master}->{$dbh} ) { 3967 PTDEBUG && _d('Server on dbh', $dbh, 'is not a master'); 3968 return; 3969 } 3970 3971 my $sth = $self->{sths}->{$dbh}->{MASTER_STATUS} 3972 ||= $dbh->prepare('SHOW MASTER STATUS'); 3973 PTDEBUG && _d($dbh, 'SHOW MASTER STATUS'); 3974 $sth->execute(); 3975 my ($ms) = @{$sth->fetchall_arrayref({})}; 3976 PTDEBUG && _d( 3977 $ms ? map { "$_=" . (defined $ms->{$_} ? $ms->{$_} : '') } keys %$ms 3978 : ''); 3979 3980 if ( !$ms || scalar keys %$ms < 2 ) { 3981 PTDEBUG && _d('Server on dbh', $dbh, 'does not seem to be a master'); 3982 $self->{not_a_master}->{$dbh}++; 3983 } 3984 3985 return { map { lc($_) => $ms->{$_} } keys %$ms }; # lowercase the keys 3986} 3987 3988sub wait_for_master { 3989 my ( $self, %args ) = @_; 3990 my @required_args = qw(master_status slave_dbh); 3991 foreach my $arg ( @required_args ) { 3992 die "I need a $arg argument" unless $args{$arg}; 3993 } 3994 my ($master_status, $slave_dbh) = @args{@required_args}; 3995 my $timeout = $args{timeout} || 60; 3996 3997 my $result; 3998 my $waited; 3999 if ( $master_status ) { 4000 my $slave_status; 4001 eval { 4002 $slave_status = $self->get_slave_status($slave_dbh); 4003 }; 4004 if ($EVAL_ERROR) { 4005 return { 4006 result => undef, 4007 waited => 0, 4008 error =>'Wait for master: this is a multi-master slave but "channel" was not specified on the command line', 4009 }; 4010 } 4011 my $server_version = VersionParser->new($slave_dbh); 4012 my $channel_sql = $server_version > '5.6' && $self->{channel} ? ", '$self->{channel}'" : ''; 4013 my $sql = "SELECT MASTER_POS_WAIT('$master_status->{file}', $master_status->{position}, $timeout $channel_sql)"; 4014 PTDEBUG && _d($slave_dbh, $sql); 4015 my $start = time; 4016 ($result) = $slave_dbh->selectrow_array($sql); 4017 4018 $waited = time - $start; 4019 4020 PTDEBUG && _d('Result of waiting:', $result); 4021 PTDEBUG && _d("Waited", $waited, "seconds"); 4022 } 4023 else { 4024 PTDEBUG && _d('Not waiting: this server is not a master'); 4025 } 4026 4027 return { 4028 result => $result, 4029 waited => $waited, 4030 }; 4031} 4032 4033sub stop_slave { 4034 my ( $self, $dbh ) = @_; 4035 my $sth = $self->{sths}->{$dbh}->{STOP_SLAVE} 4036 ||= $dbh->prepare('STOP SLAVE'); 4037 PTDEBUG && _d($dbh, $sth->{Statement}); 4038 $sth->execute(); 4039} 4040 4041sub start_slave { 4042 my ( $self, $dbh, $pos ) = @_; 4043 if ( $pos ) { 4044 my $sql = "START SLAVE UNTIL MASTER_LOG_FILE='$pos->{file}', " 4045 . "MASTER_LOG_POS=$pos->{position}"; 4046 PTDEBUG && _d($dbh, $sql); 4047 $dbh->do($sql); 4048 } 4049 else { 4050 my $sth = $self->{sths}->{$dbh}->{START_SLAVE} 4051 ||= $dbh->prepare('START SLAVE'); 4052 PTDEBUG && _d($dbh, $sth->{Statement}); 4053 $sth->execute(); 4054 } 4055} 4056 4057sub catchup_to_master { 4058 my ( $self, $slave, $master, $timeout ) = @_; 4059 $self->stop_slave($master); 4060 $self->stop_slave($slave); 4061 my $slave_status = $self->get_slave_status($slave); 4062 my $slave_pos = $self->repl_posn($slave_status); 4063 my $master_status = $self->get_master_status($master); 4064 my $master_pos = $self->repl_posn($master_status); 4065 PTDEBUG && _d('Master position:', $self->pos_to_string($master_pos), 4066 'Slave position:', $self->pos_to_string($slave_pos)); 4067 4068 my $result; 4069 if ( $self->pos_cmp($slave_pos, $master_pos) < 0 ) { 4070 PTDEBUG && _d('Waiting for slave to catch up to master'); 4071 $self->start_slave($slave, $master_pos); 4072 4073 $result = $self->wait_for_master( 4074 master_status => $master_status, 4075 slave_dbh => $slave, 4076 timeout => $timeout, 4077 master_status => $master_status 4078 ); 4079 if ($result->{error}) { 4080 die $result->{error}; 4081 } 4082 if ( !defined $result->{result} ) { 4083 $slave_status = $self->get_slave_status($slave); 4084 if ( !$self->slave_is_running($slave_status) ) { 4085 PTDEBUG && _d('Master position:', 4086 $self->pos_to_string($master_pos), 4087 'Slave position:', $self->pos_to_string($slave_pos)); 4088 $slave_pos = $self->repl_posn($slave_status); 4089 if ( $self->pos_cmp($slave_pos, $master_pos) != 0 ) { 4090 die "MASTER_POS_WAIT() returned NULL but slave has not " 4091 . "caught up to master"; 4092 } 4093 PTDEBUG && _d('Slave is caught up to master and stopped'); 4094 } 4095 else { 4096 die "Slave has not caught up to master and it is still running"; 4097 } 4098 } 4099 } 4100 else { 4101 PTDEBUG && _d("Slave is already caught up to master"); 4102 } 4103 4104 return $result; 4105} 4106 4107sub catchup_to_same_pos { 4108 my ( $self, $s1_dbh, $s2_dbh ) = @_; 4109 $self->stop_slave($s1_dbh); 4110 $self->stop_slave($s2_dbh); 4111 my $s1_status = $self->get_slave_status($s1_dbh); 4112 my $s2_status = $self->get_slave_status($s2_dbh); 4113 my $s1_pos = $self->repl_posn($s1_status); 4114 my $s2_pos = $self->repl_posn($s2_status); 4115 if ( $self->pos_cmp($s1_pos, $s2_pos) < 0 ) { 4116 $self->start_slave($s1_dbh, $s2_pos); 4117 } 4118 elsif ( $self->pos_cmp($s2_pos, $s1_pos) < 0 ) { 4119 $self->start_slave($s2_dbh, $s1_pos); 4120 } 4121 4122 $s1_status = $self->get_slave_status($s1_dbh); 4123 $s2_status = $self->get_slave_status($s2_dbh); 4124 $s1_pos = $self->repl_posn($s1_status); 4125 $s2_pos = $self->repl_posn($s2_status); 4126 4127 if ( $self->slave_is_running($s1_status) 4128 || $self->slave_is_running($s2_status) 4129 || $self->pos_cmp($s1_pos, $s2_pos) != 0) 4130 { 4131 die "The servers aren't both stopped at the same position"; 4132 } 4133 4134} 4135 4136sub slave_is_running { 4137 my ( $self, $slave_status ) = @_; 4138 return ($slave_status->{slave_sql_running} || 'No') eq 'Yes'; 4139} 4140 4141sub has_slave_updates { 4142 my ( $self, $dbh ) = @_; 4143 my $sql = q{SHOW VARIABLES LIKE 'log_slave_updates'}; 4144 PTDEBUG && _d($dbh, $sql); 4145 my ($name, $value) = $dbh->selectrow_array($sql); 4146 return $value && $value =~ m/^(1|ON)$/; 4147} 4148 4149sub repl_posn { 4150 my ( $self, $status ) = @_; 4151 if ( exists $status->{file} && exists $status->{position} ) { 4152 return { 4153 file => $status->{file}, 4154 position => $status->{position}, 4155 }; 4156 } 4157 else { 4158 return { 4159 file => $status->{relay_master_log_file}, 4160 position => $status->{exec_master_log_pos}, 4161 }; 4162 } 4163} 4164 4165sub get_slave_lag { 4166 my ( $self, $dbh ) = @_; 4167 my $stat = $self->get_slave_status($dbh); 4168 return unless $stat; # server is not a slave 4169 return $stat->{seconds_behind_master}; 4170} 4171 4172sub pos_cmp { 4173 my ( $self, $a, $b ) = @_; 4174 return $self->pos_to_string($a) cmp $self->pos_to_string($b); 4175} 4176 4177sub short_host { 4178 my ( $self, $dsn ) = @_; 4179 my ($host, $port); 4180 if ( $dsn->{master_host} ) { 4181 $host = $dsn->{master_host}; 4182 $port = $dsn->{master_port}; 4183 } 4184 else { 4185 $host = $dsn->{h}; 4186 $port = $dsn->{P}; 4187 } 4188 return ($host || '[default]') . ( ($port || 3306) == 3306 ? '' : ":$port" ); 4189} 4190 4191sub is_replication_thread { 4192 my ( $self, $query, %args ) = @_; 4193 return unless $query; 4194 4195 my $type = lc($args{type} || 'all'); 4196 die "Invalid type: $type" 4197 unless $type =~ m/^binlog_dump|slave_io|slave_sql|all$/i; 4198 4199 my $match = 0; 4200 if ( $type =~ m/binlog_dump|all/i ) { 4201 $match = 1 4202 if ($query->{Command} || $query->{command} || '') eq "Binlog Dump"; 4203 } 4204 if ( !$match ) { 4205 if ( ($query->{User} || $query->{user} || '') eq "system user" ) { 4206 PTDEBUG && _d("Slave replication thread"); 4207 if ( $type ne 'all' ) { 4208 my $state = $query->{State} || $query->{state} || ''; 4209 4210 if ( $state =~ m/^init|end$/ ) { 4211 PTDEBUG && _d("Special state:", $state); 4212 $match = 1; 4213 } 4214 else { 4215 my ($slave_sql) = $state =~ m/ 4216 ^(Waiting\sfor\sthe\snext\sevent 4217 |Reading\sevent\sfrom\sthe\srelay\slog 4218 |Has\sread\sall\srelay\slog;\swaiting 4219 |Making\stemp\sfile 4220 |Waiting\sfor\sslave\smutex\son\sexit)/xi; 4221 4222 $match = $type eq 'slave_sql' && $slave_sql ? 1 4223 : $type eq 'slave_io' && !$slave_sql ? 1 4224 : 0; 4225 } 4226 } 4227 else { 4228 $match = 1; 4229 } 4230 } 4231 else { 4232 PTDEBUG && _d('Not system user'); 4233 } 4234 4235 if ( !defined $args{check_known_ids} || $args{check_known_ids} ) { 4236 my $id = $query->{Id} || $query->{id}; 4237 if ( $match ) { 4238 $self->{replication_thread}->{$id} = 1; 4239 } 4240 else { 4241 if ( $self->{replication_thread}->{$id} ) { 4242 PTDEBUG && _d("Thread ID is a known replication thread ID"); 4243 $match = 1; 4244 } 4245 } 4246 } 4247 } 4248 4249 PTDEBUG && _d('Matches', $type, 'replication thread:', 4250 ($match ? 'yes' : 'no'), '; match:', $match); 4251 4252 return $match; 4253} 4254 4255 4256sub get_replication_filters { 4257 my ( $self, %args ) = @_; 4258 my @required_args = qw(dbh); 4259 foreach my $arg ( @required_args ) { 4260 die "I need a $arg argument" unless $args{$arg}; 4261 } 4262 my ($dbh) = @args{@required_args}; 4263 4264 my %filters = (); 4265 4266 my $status = $self->get_master_status($dbh); 4267 if ( $status ) { 4268 map { $filters{$_} = $status->{$_} } 4269 grep { defined $status->{$_} && $status->{$_} ne '' } 4270 qw( 4271 binlog_do_db 4272 binlog_ignore_db 4273 ); 4274 } 4275 4276 $status = $self->get_slave_status($dbh); 4277 if ( $status ) { 4278 map { $filters{$_} = $status->{$_} } 4279 grep { defined $status->{$_} && $status->{$_} ne '' } 4280 qw( 4281 replicate_do_db 4282 replicate_ignore_db 4283 replicate_do_table 4284 replicate_ignore_table 4285 replicate_wild_do_table 4286 replicate_wild_ignore_table 4287 ); 4288 4289 my $sql = "SHOW VARIABLES LIKE 'slave_skip_errors'"; 4290 PTDEBUG && _d($dbh, $sql); 4291 my $row = $dbh->selectrow_arrayref($sql); 4292 $filters{slave_skip_errors} = $row->[1] if $row->[1] && $row->[1] ne 'OFF'; 4293 } 4294 4295 return \%filters; 4296} 4297 4298 4299sub pos_to_string { 4300 my ( $self, $pos ) = @_; 4301 my $fmt = '%s/%020d'; 4302 return sprintf($fmt, @{$pos}{qw(file position)}); 4303} 4304 4305sub reset_known_replication_threads { 4306 my ( $self ) = @_; 4307 $self->{replication_thread} = {}; 4308 return; 4309} 4310 4311sub get_cxn_from_dsn_table { 4312 my ($self, %args) = @_; 4313 my @required_args = qw(dsn_table_dsn make_cxn); 4314 foreach my $arg ( @required_args ) { 4315 die "I need a $arg argument" unless $args{$arg}; 4316 } 4317 my ($dsn_table_dsn, $make_cxn) = @args{@required_args}; 4318 PTDEBUG && _d('DSN table DSN:', $dsn_table_dsn); 4319 4320 my $dp = $self->{DSNParser}; 4321 my $q = $self->{Quoter}; 4322 4323 my $dsn = $dp->parse($dsn_table_dsn); 4324 my $dsn_table; 4325 if ( $dsn->{D} && $dsn->{t} ) { 4326 $dsn_table = $q->quote($dsn->{D}, $dsn->{t}); 4327 } 4328 elsif ( $dsn->{t} && $dsn->{t} =~ m/\./ ) { 4329 $dsn_table = $q->quote($q->split_unquote($dsn->{t})); 4330 } 4331 else { 4332 die "DSN table DSN does not specify a database (D) " 4333 . "or a database-qualified table (t)"; 4334 } 4335 4336 my $dsn_tbl_cxn = $make_cxn->(dsn => $dsn); 4337 my $dbh = $dsn_tbl_cxn->connect(); 4338 my $sql = "SELECT dsn FROM $dsn_table ORDER BY id"; 4339 PTDEBUG && _d($sql); 4340 my $dsn_strings = $dbh->selectcol_arrayref($sql); 4341 my @cxn; 4342 if ( $dsn_strings ) { 4343 foreach my $dsn_string ( @$dsn_strings ) { 4344 PTDEBUG && _d('DSN from DSN table:', $dsn_string); 4345 push @cxn, $make_cxn->(dsn_string => $dsn_string); 4346 } 4347 } 4348 return \@cxn; 4349} 4350 4351sub _d { 4352 my ($package, undef, $line) = caller 0; 4353 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 4354 map { defined $_ ? $_ : 'undef' } 4355 @_; 4356 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 4357} 4358 43591; 4360} 4361# ########################################################################### 4362# End MasterSlave package 4363# ########################################################################### 4364 4365# ########################################################################### 4366# FlowControlWaiter package 4367# This package is a copy without comments from the original. The original 4368# with comments and its test file can be found in the Bazaar repository at, 4369# lib/FlowControlWaiter.pm 4370# t/lib/FlowControlWaiter.t 4371# See https://launchpad.net/percona-toolkit for more information. 4372# ########################################################################### 4373{ 4374package FlowControlWaiter; 4375 4376use strict; 4377use warnings FATAL => 'all'; 4378use English qw(-no_match_vars); 4379use constant PTDEBUG => $ENV{PTDEBUG} || 0; 4380 4381use Time::HiRes qw(sleep time); 4382use Data::Dumper; 4383 4384sub new { 4385 my ( $class, %args ) = @_; 4386 my @required_args = qw(oktorun node sleep max_flow_ctl); 4387 foreach my $arg ( @required_args ) { 4388 die "I need a $arg argument" unless defined $args{$arg}; 4389 } 4390 4391 my $self = { 4392 %args 4393 }; 4394 4395 $self->{last_time} = time(); 4396 4397 my (undef, $last_fc_ns) = $self->{node}->selectrow_array('SHOW STATUS LIKE "wsrep_flow_control_paused_ns"'); 4398 4399 $self->{last_fc_secs} = $last_fc_ns/1000_000_000; 4400 4401 return bless $self, $class; 4402} 4403 4404sub wait { 4405 my ( $self, %args ) = @_; 4406 my @required_args = qw(); 4407 foreach my $arg ( @required_args ) { 4408 die "I need a $arg argument" unless $args{$arg}; 4409 } 4410 my $pr = $args{Progress}; 4411 4412 my $oktorun = $self->{oktorun}; 4413 my $sleep = $self->{sleep}; 4414 my $node = $self->{node}; 4415 my $max_avg = $self->{max_flow_ctl}/100; 4416 4417 my $too_much_fc = 1; 4418 4419 my $pr_callback; 4420 if ( $pr ) { 4421 $pr_callback = sub { 4422 print STDERR "Pausing because PXC Flow Control is active\n"; 4423 return; 4424 }; 4425 $pr->set_callback($pr_callback); 4426 } 4427 4428 while ( $oktorun->() && $too_much_fc ) { 4429 my $current_time = time(); 4430 my (undef, $current_fc_ns) = $node->selectrow_array('SHOW STATUS LIKE "wsrep_flow_control_paused_ns"'); 4431 my $current_fc_secs = $current_fc_ns/1000_000_000; 4432 my $current_avg = ($current_fc_secs - $self->{last_fc_secs}) / ($current_time - $self->{last_time}); 4433 if ( $current_avg > $max_avg ) { 4434 if ( $pr ) { 4435 $pr->update(sub { return 0; }); 4436 } 4437 PTDEBUG && _d('Calling sleep callback'); 4438 if ( $self->{simple_progress} ) { 4439 print STDERR "Waiting for Flow Control to abate\n"; 4440 } 4441 $sleep->(); 4442 } else { 4443 $too_much_fc = 0; 4444 } 4445 $self->{last_time} = $current_time; 4446 $self->{last_fc_secs} = $current_fc_secs; 4447 4448 4449 } 4450 4451 PTDEBUG && _d('Flow Control is Ok'); 4452 return; 4453} 4454 4455sub _d { 4456 my ($package, undef, $line) = caller 0; 4457 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 4458 map { defined $_ ? $_ : 'undef' } 4459 @_; 4460 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 4461} 4462 44631; 4464} 4465# ########################################################################### 4466# End FlowControlWaiter package 4467# ########################################################################### 4468 4469# ########################################################################### 4470# Cxn package 4471# This package is a copy without comments from the original. The original 4472# with comments and its test file can be found in the Bazaar repository at, 4473# lib/Cxn.pm 4474# t/lib/Cxn.t 4475# See https://launchpad.net/percona-toolkit for more information. 4476# ########################################################################### 4477{ 4478package Cxn; 4479 4480use strict; 4481use warnings FATAL => 'all'; 4482use English qw(-no_match_vars); 4483use Scalar::Util qw(blessed); 4484use constant { 4485 PTDEBUG => $ENV{PTDEBUG} || 0, 4486 PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0, 4487}; 4488 4489sub new { 4490 my ( $class, %args ) = @_; 4491 my @required_args = qw(DSNParser OptionParser); 4492 foreach my $arg ( @required_args ) { 4493 die "I need a $arg argument" unless $args{$arg}; 4494 }; 4495 my ($dp, $o) = @args{@required_args}; 4496 4497 my $dsn_defaults = $dp->parse_options($o); 4498 my $prev_dsn = $args{prev_dsn}; 4499 my $dsn = $args{dsn}; 4500 if ( !$dsn ) { 4501 $args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost'); 4502 4503 $dsn = $dp->parse( 4504 $args{dsn_string}, $prev_dsn, $dsn_defaults); 4505 } 4506 elsif ( $prev_dsn ) { 4507 $dsn = $dp->copy($prev_dsn, $dsn); 4508 } 4509 4510 my $dsn_name = $dp->as_string($dsn, [qw(h P S)]) 4511 || $dp->as_string($dsn, [qw(F)]) 4512 || ''; 4513 4514 my $self = { 4515 dsn => $dsn, 4516 dbh => $args{dbh}, 4517 dsn_name => $dsn_name, 4518 hostname => '', 4519 set => $args{set}, 4520 NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1, 4521 dbh_set => 0, 4522 ask_pass => $o->get('ask-pass'), 4523 DSNParser => $dp, 4524 is_cluster_node => undef, 4525 parent => $args{parent}, 4526 }; 4527 4528 return bless $self, $class; 4529} 4530 4531sub connect { 4532 my ( $self, %opts ) = @_; 4533 my $dsn = $opts{dsn} || $self->{dsn}; 4534 my $dp = $self->{DSNParser}; 4535 4536 my $dbh = $self->{dbh}; 4537 if ( !$dbh || !$dbh->ping() ) { 4538 if ( $self->{ask_pass} && !$self->{asked_for_pass} && !defined $dsn->{p} ) { 4539 $dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: "); 4540 $self->{asked_for_pass} = 1; 4541 } 4542 $dbh = $dp->get_dbh( 4543 $dp->get_cxn_params($dsn), 4544 { 4545 AutoCommit => 1, 4546 %opts, 4547 }, 4548 ); 4549 } 4550 4551 $dbh = $self->set_dbh($dbh); 4552 if ( $opts{dsn} ) { 4553 $self->{dsn} = $dsn; 4554 $self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)]) 4555 || $dp->as_string($dsn, [qw(F)]) 4556 || ''; 4557 4558 } 4559 PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name}); 4560 return $dbh; 4561} 4562 4563sub set_dbh { 4564 my ($self, $dbh) = @_; 4565 4566 if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) { 4567 PTDEBUG && _d($dbh, 'Already set dbh'); 4568 return $dbh; 4569 } 4570 4571 PTDEBUG && _d($dbh, 'Setting dbh'); 4572 4573 $dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc}; 4574 4575 my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/'; 4576 PTDEBUG && _d($dbh, $sql); 4577 my ($server_id, $hostname) = $dbh->selectrow_array($sql); 4578 PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id); 4579 if ( $hostname ) { 4580 $self->{hostname} = $hostname; 4581 } 4582 4583 if ( $self->{parent} ) { 4584 PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent'); 4585 $dbh->{InactiveDestroy} = 1; 4586 } 4587 4588 if ( my $set = $self->{set}) { 4589 $set->($dbh); 4590 } 4591 4592 $self->{dbh} = $dbh; 4593 $self->{dbh_set} = 1; 4594 return $dbh; 4595} 4596 4597sub lost_connection { 4598 my ($self, $e) = @_; 4599 return 0 unless $e; 4600 return $e =~ m/MySQL server has gone away/ 4601 || $e =~ m/Lost connection to MySQL server/ 4602 || $e =~ m/Server shutdown in progress/; 4603} 4604 4605sub dbh { 4606 my ($self) = @_; 4607 return $self->{dbh}; 4608} 4609 4610sub dsn { 4611 my ($self) = @_; 4612 return $self->{dsn}; 4613} 4614 4615sub name { 4616 my ($self) = @_; 4617 return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES; 4618 return $self->{hostname} || $self->{dsn_name} || 'unknown host'; 4619} 4620 4621sub description { 4622 my ($self) = @_; 4623 return sprintf("%s -> %s:%s", $self->name(), $self->{dsn}->{h}, $self->{dsn}->{P} || 'socket'); 4624} 4625 4626sub get_id { 4627 my ($self, $cxn) = @_; 4628 4629 $cxn ||= $self; 4630 4631 my $unique_id; 4632 if ($cxn->is_cluster_node()) { # for cluster we concatenate various variables to maximize id 'uniqueness' across versions 4633 my $sql = q{SHOW STATUS LIKE 'wsrep\_local\_index'}; 4634 my (undef, $wsrep_local_index) = $cxn->dbh->selectrow_array($sql); 4635 PTDEBUG && _d("Got cluster wsrep_local_index: ",$wsrep_local_index); 4636 $unique_id = $wsrep_local_index."|"; 4637 foreach my $val ('server\_id', 'wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') { 4638 my $sql = "SHOW VARIABLES LIKE '$val'"; 4639 PTDEBUG && _d($cxn->name, $sql); 4640 my (undef, $val) = $cxn->dbh->selectrow_array($sql); 4641 $unique_id .= "|$val"; 4642 } 4643 } else { 4644 my $sql = 'SELECT @@SERVER_ID'; 4645 PTDEBUG && _d($sql); 4646 $unique_id = $cxn->dbh->selectrow_array($sql); 4647 } 4648 PTDEBUG && _d("Generated unique id for cluster:", $unique_id); 4649 return $unique_id; 4650} 4651 4652 4653sub is_cluster_node { 4654 my ($self, $cxn) = @_; 4655 4656 $cxn ||= $self; 4657 4658 my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'"; 4659 4660 my $dbh; 4661 if ($cxn->isa('DBI::db')) { 4662 $dbh = $cxn; 4663 PTDEBUG && _d($sql); #don't invoke name() if it's not a Cxn! 4664 } 4665 else { 4666 $dbh = $cxn->dbh(); 4667 PTDEBUG && _d($cxn->name, $sql); 4668 } 4669 4670 my $row = $dbh->selectrow_arrayref($sql); 4671 return $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1') ? 1 : 0; 4672 4673} 4674 4675sub remove_duplicate_cxns { 4676 my ($self, %args) = @_; 4677 my @cxns = @{$args{cxns}}; 4678 my $seen_ids = $args{seen_ids} || {}; 4679 PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns)); 4680 my @trimmed_cxns; 4681 4682 for my $cxn ( @cxns ) { 4683 4684 my $id = $cxn->get_id(); 4685 PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id); 4686 4687 if ( ! $seen_ids->{$id}++ ) { 4688 push @trimmed_cxns, $cxn 4689 } 4690 else { 4691 PTDEBUG && _d("Removing ", $cxn->name, 4692 ", ID ", $id, ", because we've already seen it"); 4693 } 4694 } 4695 4696 return \@trimmed_cxns; 4697} 4698 4699sub DESTROY { 4700 my ($self) = @_; 4701 4702 PTDEBUG && _d('Destroying cxn'); 4703 4704 if ( $self->{parent} ) { 4705 PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent'); 4706 } 4707 elsif ( $self->{dbh} 4708 && blessed($self->{dbh}) 4709 && $self->{dbh}->can("disconnect") ) 4710 { 4711 PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname}, 4712 $self->{dsn_name}); 4713 $self->{dbh}->disconnect(); 4714 } 4715 4716 return; 4717} 4718 4719sub _d { 4720 my ($package, undef, $line) = caller 0; 4721 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 4722 map { defined $_ ? $_ : 'undef' } 4723 @_; 4724 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 4725} 4726 47271; 4728} 4729# ########################################################################### 4730# End Cxn package 4731# ########################################################################### 4732 4733 4734# ########################################################################### 4735# HTTP::Micro package 4736# This package is a copy without comments from the original. The original 4737# with comments and its test file can be found in the Bazaar repository at, 4738# lib/HTTP/Micro.pm 4739# t/lib/HTTP/Micro.t 4740# See https://launchpad.net/percona-toolkit for more information. 4741# ########################################################################### 4742{ 4743package HTTP::Micro; 4744 4745our $VERSION = '0.01'; 4746 4747use strict; 4748use warnings FATAL => 'all'; 4749use English qw(-no_match_vars); 4750use Carp (); 4751 4752my @attributes; 4753BEGIN { 4754 @attributes = qw(agent timeout); 4755 no strict 'refs'; 4756 for my $accessor ( @attributes ) { 4757 *{$accessor} = sub { 4758 @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor}; 4759 }; 4760 } 4761} 4762 4763sub new { 4764 my($class, %args) = @_; 4765 (my $agent = $class) =~ s{::}{-}g; 4766 my $self = { 4767 agent => $agent . "/" . ($class->VERSION || 0), 4768 timeout => 60, 4769 }; 4770 for my $key ( @attributes ) { 4771 $self->{$key} = $args{$key} if exists $args{$key} 4772 } 4773 return bless $self, $class; 4774} 4775 4776my %DefaultPort = ( 4777 http => 80, 4778 https => 443, 4779); 4780 4781sub request { 4782 my ($self, $method, $url, $args) = @_; 4783 @_ == 3 || (@_ == 4 && ref $args eq 'HASH') 4784 or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/); 4785 $args ||= {}; # we keep some state in this during _request 4786 4787 my $response; 4788 for ( 0 .. 1 ) { 4789 $response = eval { $self->_request($method, $url, $args) }; 4790 last unless $@ && $method eq 'GET' 4791 && $@ =~ m{^(?:Socket closed|Unexpected end)}; 4792 } 4793 4794 if (my $e = "$@") { 4795 $response = { 4796 success => q{}, 4797 status => 599, 4798 reason => 'Internal Exception', 4799 content => $e, 4800 headers => { 4801 'content-type' => 'text/plain', 4802 'content-length' => length $e, 4803 } 4804 }; 4805 } 4806 return $response; 4807} 4808 4809sub _request { 4810 my ($self, $method, $url, $args) = @_; 4811 4812 my ($scheme, $host, $port, $path_query) = $self->_split_url($url); 4813 4814 my $request = { 4815 method => $method, 4816 scheme => $scheme, 4817 host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), 4818 uri => $path_query, 4819 headers => {}, 4820 }; 4821 4822 my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout}); 4823 4824 $handle->connect($scheme, $host, $port); 4825 4826 $self->_prepare_headers_and_cb($request, $args); 4827 $handle->write_request_header(@{$request}{qw/method uri headers/}); 4828 $handle->write_content_body($request) if $request->{content}; 4829 4830 my $response; 4831 do { $response = $handle->read_response_header } 4832 until (substr($response->{status},0,1) ne '1'); 4833 4834 if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) { 4835 $response->{content} = ''; 4836 $handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response); 4837 } 4838 4839 $handle->close; 4840 $response->{success} = substr($response->{status},0,1) eq '2'; 4841 return $response; 4842} 4843 4844sub _prepare_headers_and_cb { 4845 my ($self, $request, $args) = @_; 4846 4847 for ($args->{headers}) { 4848 next unless defined; 4849 while (my ($k, $v) = each %$_) { 4850 $request->{headers}{lc $k} = $v; 4851 } 4852 } 4853 $request->{headers}{'host'} = $request->{host_port}; 4854 $request->{headers}{'connection'} = "close"; 4855 $request->{headers}{'user-agent'} ||= $self->{agent}; 4856 4857 if (defined $args->{content}) { 4858 $request->{headers}{'content-type'} ||= "application/octet-stream"; 4859 utf8::downgrade($args->{content}, 1) 4860 or Carp::croak(q/Wide character in request message body/); 4861 $request->{headers}{'content-length'} = length $args->{content}; 4862 $request->{content} = $args->{content}; 4863 } 4864 return; 4865} 4866 4867sub _split_url { 4868 my $url = pop; 4869 4870 my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> 4871 or Carp::croak(qq/Cannot parse URL: '$url'/); 4872 4873 $scheme = lc $scheme; 4874 $path_query = "/$path_query" unless $path_query =~ m<\A/>; 4875 4876 my $host = (length($authority)) ? lc $authority : 'localhost'; 4877 $host =~ s/\A[^@]*@//; # userinfo 4878 my $port = do { 4879 $host =~ s/:([0-9]*)\z// && length $1 4880 ? $1 4881 : $DefaultPort{$scheme} 4882 }; 4883 4884 return ($scheme, $host, $port, $path_query); 4885} 4886 4887} # HTTP::Micro 4888 4889{ 4890 package HTTP::Micro::Handle; 4891 4892 use strict; 4893 use warnings FATAL => 'all'; 4894 use English qw(-no_match_vars); 4895 4896 use Carp qw(croak); 4897 use Errno qw(EINTR EPIPE); 4898 use IO::Socket qw(SOCK_STREAM); 4899 4900 sub BUFSIZE () { 32768 } 4901 4902 my $Printable = sub { 4903 local $_ = shift; 4904 s/\r/\\r/g; 4905 s/\n/\\n/g; 4906 s/\t/\\t/g; 4907 s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; 4908 $_; 4909 }; 4910 4911 sub new { 4912 my ($class, %args) = @_; 4913 return bless { 4914 rbuf => '', 4915 timeout => 60, 4916 max_line_size => 16384, 4917 %args 4918 }, $class; 4919 } 4920 4921 my $ssl_verify_args = { 4922 check_cn => "when_only", 4923 wildcards_in_alt => "anywhere", 4924 wildcards_in_cn => "anywhere" 4925 }; 4926 4927 sub connect { 4928 @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); 4929 my ($self, $scheme, $host, $port) = @_; 4930 4931 if ( $scheme eq 'https' ) { 4932 eval "require IO::Socket::SSL" 4933 unless exists $INC{'IO/Socket/SSL.pm'}; 4934 croak(qq/IO::Socket::SSL must be installed for https support\n/) 4935 unless $INC{'IO/Socket/SSL.pm'}; 4936 } 4937 elsif ( $scheme ne 'http' ) { 4938 croak(qq/Unsupported URL scheme '$scheme'\n/); 4939 } 4940 4941 $self->{fh} = IO::Socket::INET->new( 4942 PeerHost => $host, 4943 PeerPort => $port, 4944 Proto => 'tcp', 4945 Type => SOCK_STREAM, 4946 Timeout => $self->{timeout} 4947 ) or croak(qq/Could not connect to '$host:$port': $@/); 4948 4949 binmode($self->{fh}) 4950 or croak(qq/Could not binmode() socket: '$!'/); 4951 4952 if ( $scheme eq 'https') { 4953 IO::Socket::SSL->start_SSL($self->{fh}); 4954 ref($self->{fh}) eq 'IO::Socket::SSL' 4955 or die(qq/SSL connection failed for $host\n/); 4956 if ( $self->{fh}->can("verify_hostname") ) { 4957 $self->{fh}->verify_hostname( $host, $ssl_verify_args ) 4958 or die(qq/SSL certificate not valid for $host\n/); 4959 } 4960 else { 4961 my $fh = $self->{fh}; 4962 _verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args) 4963 or die(qq/SSL certificate not valid for $host\n/); 4964 } 4965 } 4966 4967 $self->{host} = $host; 4968 $self->{port} = $port; 4969 4970 return $self; 4971 } 4972 4973 sub close { 4974 @_ == 1 || croak(q/Usage: $handle->close()/); 4975 my ($self) = @_; 4976 CORE::close($self->{fh}) 4977 or croak(qq/Could not close socket: '$!'/); 4978 } 4979 4980 sub write { 4981 @_ == 2 || croak(q/Usage: $handle->write(buf)/); 4982 my ($self, $buf) = @_; 4983 4984 my $len = length $buf; 4985 my $off = 0; 4986 4987 local $SIG{PIPE} = 'IGNORE'; 4988 4989 while () { 4990 $self->can_write 4991 or croak(q/Timed out while waiting for socket to become ready for writing/); 4992 my $r = syswrite($self->{fh}, $buf, $len, $off); 4993 if (defined $r) { 4994 $len -= $r; 4995 $off += $r; 4996 last unless $len > 0; 4997 } 4998 elsif ($! == EPIPE) { 4999 croak(qq/Socket closed by remote server: $!/); 5000 } 5001 elsif ($! != EINTR) { 5002 croak(qq/Could not write to socket: '$!'/); 5003 } 5004 } 5005 return $off; 5006 } 5007 5008 sub read { 5009 @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/); 5010 my ($self, $len) = @_; 5011 5012 my $buf = ''; 5013 my $got = length $self->{rbuf}; 5014 5015 if ($got) { 5016 my $take = ($got < $len) ? $got : $len; 5017 $buf = substr($self->{rbuf}, 0, $take, ''); 5018 $len -= $take; 5019 } 5020 5021 while ($len > 0) { 5022 $self->can_read 5023 or croak(q/Timed out while waiting for socket to become ready for reading/); 5024 my $r = sysread($self->{fh}, $buf, $len, length $buf); 5025 if (defined $r) { 5026 last unless $r; 5027 $len -= $r; 5028 } 5029 elsif ($! != EINTR) { 5030 croak(qq/Could not read from socket: '$!'/); 5031 } 5032 } 5033 if ($len) { 5034 croak(q/Unexpected end of stream/); 5035 } 5036 return $buf; 5037 } 5038 5039 sub readline { 5040 @_ == 1 || croak(q/Usage: $handle->readline()/); 5041 my ($self) = @_; 5042 5043 while () { 5044 if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { 5045 return $1; 5046 } 5047 $self->can_read 5048 or croak(q/Timed out while waiting for socket to become ready for reading/); 5049 my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); 5050 if (defined $r) { 5051 last unless $r; 5052 } 5053 elsif ($! != EINTR) { 5054 croak(qq/Could not read from socket: '$!'/); 5055 } 5056 } 5057 croak(q/Unexpected end of stream while looking for line/); 5058 } 5059 5060 sub read_header_lines { 5061 @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); 5062 my ($self, $headers) = @_; 5063 $headers ||= {}; 5064 my $lines = 0; 5065 my $val; 5066 5067 while () { 5068 my $line = $self->readline; 5069 5070 if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { 5071 my ($field_name) = lc $1; 5072 $val = \($headers->{$field_name} = $2); 5073 } 5074 elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { 5075 $val 5076 or croak(q/Unexpected header continuation line/); 5077 next unless length $1; 5078 $$val .= ' ' if length $$val; 5079 $$val .= $1; 5080 } 5081 elsif ($line =~ /\A \x0D?\x0A \z/x) { 5082 last; 5083 } 5084 else { 5085 croak(q/Malformed header line: / . $Printable->($line)); 5086 } 5087 } 5088 return $headers; 5089 } 5090 5091 sub write_header_lines { 5092 (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); 5093 my($self, $headers) = @_; 5094 5095 my $buf = ''; 5096 while (my ($k, $v) = each %$headers) { 5097 my $field_name = lc $k; 5098 $field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x 5099 or croak(q/Invalid HTTP header field name: / . $Printable->($field_name)); 5100 $field_name =~ s/\b(\w)/\u$1/g; 5101 $buf .= "$field_name: $v\x0D\x0A"; 5102 } 5103 $buf .= "\x0D\x0A"; 5104 return $self->write($buf); 5105 } 5106 5107 sub read_content_body { 5108 @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); 5109 my ($self, $cb, $response, $len) = @_; 5110 $len ||= $response->{headers}{'content-length'}; 5111 5112 croak("No content-length in the returned response, and this " 5113 . "UA doesn't implement chunking") unless defined $len; 5114 5115 while ($len > 0) { 5116 my $read = ($len > BUFSIZE) ? BUFSIZE : $len; 5117 $cb->($self->read($read), $response); 5118 $len -= $read; 5119 } 5120 5121 return; 5122 } 5123 5124 sub write_content_body { 5125 @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/); 5126 my ($self, $request) = @_; 5127 my ($len, $content_length) = (0, $request->{headers}{'content-length'}); 5128 5129 $len += $self->write($request->{content}); 5130 5131 $len == $content_length 5132 or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); 5133 5134 return $len; 5135 } 5136 5137 sub read_response_header { 5138 @_ == 1 || croak(q/Usage: $handle->read_response_header()/); 5139 my ($self) = @_; 5140 5141 my $line = $self->readline; 5142 5143 $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x 5144 or croak(q/Malformed Status-Line: / . $Printable->($line)); 5145 5146 my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); 5147 5148 return { 5149 status => $status, 5150 reason => $reason, 5151 headers => $self->read_header_lines, 5152 protocol => $protocol, 5153 }; 5154 } 5155 5156 sub write_request_header { 5157 @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/); 5158 my ($self, $method, $request_uri, $headers) = @_; 5159 5160 return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") 5161 + $self->write_header_lines($headers); 5162 } 5163 5164 sub _do_timeout { 5165 my ($self, $type, $timeout) = @_; 5166 $timeout = $self->{timeout} 5167 unless defined $timeout && $timeout >= 0; 5168 5169 my $fd = fileno $self->{fh}; 5170 defined $fd && $fd >= 0 5171 or croak(q/select(2): 'Bad file descriptor'/); 5172 5173 my $initial = time; 5174 my $pending = $timeout; 5175 my $nfound; 5176 5177 vec(my $fdset = '', $fd, 1) = 1; 5178 5179 while () { 5180 $nfound = ($type eq 'read') 5181 ? select($fdset, undef, undef, $pending) 5182 : select(undef, $fdset, undef, $pending) ; 5183 if ($nfound == -1) { 5184 $! == EINTR 5185 or croak(qq/select(2): '$!'/); 5186 redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; 5187 $nfound = 0; 5188 } 5189 last; 5190 } 5191 $! = 0; 5192 return $nfound; 5193 } 5194 5195 sub can_read { 5196 @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/); 5197 my $self = shift; 5198 return $self->_do_timeout('read', @_) 5199 } 5200 5201 sub can_write { 5202 @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/); 5203 my $self = shift; 5204 return $self->_do_timeout('write', @_) 5205 } 5206} # HTTP::Micro::Handle 5207 5208my $prog = <<'EOP'; 5209BEGIN { 5210 if ( defined &IO::Socket::SSL::CAN_IPV6 ) { 5211 *CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6; 5212 } 5213 else { 5214 constant->import( CAN_IPV6 => '' ); 5215 } 5216 my %const = ( 5217 NID_CommonName => 13, 5218 GEN_DNS => 2, 5219 GEN_IPADD => 7, 5220 ); 5221 while ( my ($name,$value) = each %const ) { 5222 no strict 'refs'; 5223 *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value }; 5224 } 5225} 5226{ 5227 use Carp qw(croak); 5228 my %dispatcher = ( 5229 issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) }, 5230 subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) }, 5231 ); 5232 if ( $Net::SSLeay::VERSION >= 1.30 ) { 5233 $dispatcher{commonName} = sub { 5234 my $cn = Net::SSLeay::X509_NAME_get_text_by_NID( 5235 Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName); 5236 $cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33 5237 $cn; 5238 } 5239 } else { 5240 $dispatcher{commonName} = sub { 5241 croak "you need at least Net::SSLeay version 1.30 for getting commonName" 5242 } 5243 } 5244 5245 if ( $Net::SSLeay::VERSION >= 1.33 ) { 5246 $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; 5247 } else { 5248 $dispatcher{subjectAltNames} = sub { 5249 return; 5250 }; 5251 } 5252 5253 $dispatcher{authority} = $dispatcher{issuer}; 5254 $dispatcher{owner} = $dispatcher{subject}; 5255 $dispatcher{cn} = $dispatcher{commonName}; 5256 5257 sub _peer_certificate { 5258 my ($self, $field) = @_; 5259 my $ssl = $self->_get_ssl_object or return; 5260 5261 my $cert = ${*$self}{_SSL_certificate} 5262 ||= Net::SSLeay::get_peer_certificate($ssl) 5263 or return $self->error("Could not retrieve peer certificate"); 5264 5265 if ($field) { 5266 my $sub = $dispatcher{$field} or croak 5267 "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ). 5268 "\nMaybe you need to upgrade your Net::SSLeay"; 5269 return $sub->($cert); 5270 } else { 5271 return $cert 5272 } 5273 } 5274 5275 5276 my %scheme = ( 5277 ldap => { 5278 wildcards_in_cn => 0, 5279 wildcards_in_alt => 'leftmost', 5280 check_cn => 'always', 5281 }, 5282 http => { 5283 wildcards_in_cn => 'anywhere', 5284 wildcards_in_alt => 'anywhere', 5285 check_cn => 'when_only', 5286 }, 5287 smtp => { 5288 wildcards_in_cn => 0, 5289 wildcards_in_alt => 0, 5290 check_cn => 'always' 5291 }, 5292 none => {}, # do not check 5293 ); 5294 5295 $scheme{www} = $scheme{http}; # alias 5296 $scheme{xmpp} = $scheme{http}; # rfc 3920 5297 $scheme{pop3} = $scheme{ldap}; # rfc 2595 5298 $scheme{imap} = $scheme{ldap}; # rfc 2595 5299 $scheme{acap} = $scheme{ldap}; # rfc 2595 5300 $scheme{nntp} = $scheme{ldap}; # rfc 4642 5301 $scheme{ftp} = $scheme{http}; # rfc 4217 5302 5303 5304 sub _verify_hostname_of_cert { 5305 my $identity = shift; 5306 my $cert = shift; 5307 my $scheme = shift || 'none'; 5308 if ( ! ref($scheme) ) { 5309 $scheme = $scheme{$scheme} or croak "scheme $scheme not defined"; 5310 } 5311 5312 return 1 if ! %$scheme; # 'none' 5313 5314 my $commonName = $dispatcher{cn}->($cert); 5315 my @altNames = $dispatcher{subjectAltNames}->($cert); 5316 5317 if ( my $sub = $scheme->{callback} ) { 5318 return $sub->($identity,$commonName,@altNames); 5319 } 5320 5321 5322 my $ipn; 5323 if ( CAN_IPV6 and $identity =~m{:} ) { 5324 $ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity) 5325 or croak "'$identity' is not IPv6, but neither IPv4 nor hostname"; 5326 } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) { 5327 $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; 5328 } else { 5329 if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) { 5330 $identity =~m{\0} and croak("name '$identity' has \\0 byte"); 5331 $identity = IO::Socket::SSL::idn_to_ascii($identity) or 5332 croak "Warning: Given name '$identity' could not be converted to IDNA!"; 5333 } 5334 } 5335 5336 my $check_name = sub { 5337 my ($name,$identity,$wtyp) = @_; 5338 $wtyp ||= ''; 5339 my $pattern; 5340 if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) { 5341 $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i; 5342 } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) { 5343 $pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i; 5344 } else { 5345 $pattern = qr{^\Q$name\E$}i; 5346 } 5347 return $identity =~ $pattern; 5348 }; 5349 5350 my $alt_dnsNames = 0; 5351 while (@altNames) { 5352 my ($type, $name) = splice (@altNames, 0, 2); 5353 if ( $ipn and $type == GEN_IPADD ) { 5354 return 1 if $ipn eq $name; 5355 5356 } elsif ( ! $ipn and $type == GEN_DNS ) { 5357 $name =~s/\s+$//; $name =~s/^\s+//; 5358 $alt_dnsNames++; 5359 $check_name->($name,$identity,$scheme->{wildcards_in_alt}) 5360 and return 1; 5361 } 5362 } 5363 5364 if ( ! $ipn and ( 5365 $scheme->{check_cn} eq 'always' or 5366 $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) { 5367 $check_name->($commonName,$identity,$scheme->{wildcards_in_cn}) 5368 and return 1; 5369 } 5370 5371 return 0; # no match 5372 } 5373} 5374EOP 5375 5376eval { require IO::Socket::SSL }; 5377if ( $INC{"IO/Socket/SSL.pm"} ) { 5378 eval $prog; 5379 die $@ if $@; 5380} 5381 53821; 5383# ########################################################################### 5384# End HTTP::Micro package 5385# ########################################################################### 5386 5387# ########################################################################### 5388# VersionCheck package 5389# This package is a copy without comments from the original. The original 5390# with comments and its test file can be found in the Bazaar repository at, 5391# lib/VersionCheck.pm 5392# t/lib/VersionCheck.t 5393# See https://launchpad.net/percona-toolkit for more information. 5394# ########################################################################### 5395{ 5396package VersionCheck; 5397 5398 5399use strict; 5400use warnings FATAL => 'all'; 5401use English qw(-no_match_vars); 5402 5403use constant PTDEBUG => $ENV{PTDEBUG} || 0; 5404 5405use Data::Dumper; 5406local $Data::Dumper::Indent = 1; 5407local $Data::Dumper::Sortkeys = 1; 5408local $Data::Dumper::Quotekeys = 0; 5409 5410use Digest::MD5 qw(md5_hex); 5411use Sys::Hostname qw(hostname); 5412use File::Basename qw(); 5413use File::Spec; 5414use FindBin qw(); 5415 5416eval { 5417 require Percona::Toolkit; 5418 require HTTP::Micro; 5419}; 5420 5421my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.'; 5422my @vc_dirs = ( 5423 '/etc/percona', 5424 '/etc/percona-toolkit', 5425 '/tmp', 5426 "$home", 5427); 5428 5429{ 5430 my $file = 'percona-version-check'; 5431 5432 sub version_check_file { 5433 foreach my $dir ( @vc_dirs ) { 5434 if ( -d $dir && -w $dir ) { 5435 PTDEBUG && _d('Version check file', $file, 'in', $dir); 5436 return $dir . '/' . $file; 5437 } 5438 } 5439 PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD}); 5440 return $file; # in the CWD 5441 } 5442} 5443 5444sub version_check_time_limit { 5445 return 60 * 60 * 24; # one day 5446} 5447 5448 5449sub version_check { 5450 my (%args) = @_; 5451 5452 my $instances = $args{instances} || []; 5453 my $instances_to_check; 5454 5455 PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin); 5456 if ( !$args{force} ) { 5457 if ( $FindBin::Bin 5458 && (-d "$FindBin::Bin/../.bzr" || 5459 -d "$FindBin::Bin/../../.bzr" || 5460 -d "$FindBin::Bin/../.git" || 5461 -d "$FindBin::Bin/../../.git" 5462 ) 5463 ) { 5464 PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check"); 5465 return; 5466 } 5467 } 5468 5469 eval { 5470 foreach my $instance ( @$instances ) { 5471 my ($name, $id) = get_instance_id($instance); 5472 $instance->{name} = $name; 5473 $instance->{id} = $id; 5474 } 5475 5476 push @$instances, { name => 'system', id => 0 }; 5477 5478 $instances_to_check = get_instances_to_check( 5479 instances => $instances, 5480 vc_file => $args{vc_file}, # testing 5481 now => $args{now}, # testing 5482 ); 5483 PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); 5484 return unless @$instances_to_check; 5485 5486 my $protocol = 'https'; 5487 eval { require IO::Socket::SSL; }; 5488 if ( $EVAL_ERROR ) { 5489 PTDEBUG && _d($EVAL_ERROR); 5490 PTDEBUG && _d("SSL not available, won't run version_check"); 5491 return; 5492 } 5493 PTDEBUG && _d('Using', $protocol); 5494 5495 my $advice = pingback( 5496 instances => $instances_to_check, 5497 protocol => $protocol, 5498 url => $args{url} # testing 5499 || $ENV{PERCONA_VERSION_CHECK_URL} # testing 5500 || "$protocol://v.percona.com", 5501 ); 5502 if ( $advice ) { 5503 PTDEBUG && _d('Advice:', Dumper($advice)); 5504 if ( scalar @$advice > 1) { 5505 print "\n# " . scalar @$advice . " software updates are " 5506 . "available:\n"; 5507 } 5508 else { 5509 print "\n# A software update is available:\n"; 5510 } 5511 print join("\n", map { "# * $_" } @$advice), "\n\n"; 5512 } 5513 }; 5514 if ( $EVAL_ERROR ) { 5515 PTDEBUG && _d('Version check failed:', $EVAL_ERROR); 5516 } 5517 5518 if ( @$instances_to_check ) { 5519 eval { 5520 update_check_times( 5521 instances => $instances_to_check, 5522 vc_file => $args{vc_file}, # testing 5523 now => $args{now}, # testing 5524 ); 5525 }; 5526 if ( $EVAL_ERROR ) { 5527 PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR); 5528 } 5529 } 5530 5531 if ( $ENV{PTDEBUG_VERSION_CHECK} ) { 5532 warn "Exiting because the PTDEBUG_VERSION_CHECK " 5533 . "environment variable is defined.\n"; 5534 exit 255; 5535 } 5536 5537 return; 5538} 5539 5540sub get_instances_to_check { 5541 my (%args) = @_; 5542 5543 my $instances = $args{instances}; 5544 my $now = $args{now} || int(time); 5545 my $vc_file = $args{vc_file} || version_check_file(); 5546 5547 if ( !-f $vc_file ) { 5548 PTDEBUG && _d('Version check file', $vc_file, 'does not exist;', 5549 'version checking all instances'); 5550 return $instances; 5551 } 5552 5553 open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; 5554 chomp(my $file_contents = do { local $/ = undef; <$fh> }); 5555 PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents); 5556 close $fh; 5557 my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; 5558 5559 my $check_time_limit = version_check_time_limit(); 5560 my @instances_to_check; 5561 foreach my $instance ( @$instances ) { 5562 my $last_check_time = $last_check_time_for{ $instance->{id} }; 5563 PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', 5564 $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0), 5565 'hours until next check', 5566 sprintf '%.2f', 5567 ($check_time_limit - ($now - ($last_check_time || 0))) / 3600); 5568 if ( !defined $last_check_time 5569 || ($now - $last_check_time) >= $check_time_limit ) { 5570 PTDEBUG && _d('Time to check', Dumper($instance)); 5571 push @instances_to_check, $instance; 5572 } 5573 } 5574 5575 return \@instances_to_check; 5576} 5577 5578sub update_check_times { 5579 my (%args) = @_; 5580 5581 my $instances = $args{instances}; 5582 my $now = $args{now} || int(time); 5583 my $vc_file = $args{vc_file} || version_check_file(); 5584 PTDEBUG && _d('Updating last check time:', $now); 5585 5586 my %all_instances = map { 5587 $_->{id} => { name => $_->{name}, ts => $now } 5588 } @$instances; 5589 5590 if ( -f $vc_file ) { 5591 open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR"; 5592 my $contents = do { local $/ = undef; <$fh> }; 5593 close $fh; 5594 5595 foreach my $line ( split("\n", ($contents || '')) ) { 5596 my ($id, $ts) = split(',', $line); 5597 if ( !exists $all_instances{$id} ) { 5598 $all_instances{$id} = { ts => $ts }; # original ts, not updated 5599 } 5600 } 5601 } 5602 5603 open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; 5604 foreach my $id ( sort keys %all_instances ) { 5605 PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id})); 5606 print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n"; 5607 } 5608 close $fh; 5609 5610 return; 5611} 5612 5613sub get_instance_id { 5614 my ($instance) = @_; 5615 5616 my $dbh = $instance->{dbh}; 5617 my $dsn = $instance->{dsn}; 5618 5619 my $sql = q{SELECT CONCAT(@@hostname, @@port)}; 5620 PTDEBUG && _d($sql); 5621 my ($name) = eval { $dbh->selectrow_array($sql) }; 5622 if ( $EVAL_ERROR ) { 5623 PTDEBUG && _d($EVAL_ERROR); 5624 $sql = q{SELECT @@hostname}; 5625 PTDEBUG && _d($sql); 5626 ($name) = eval { $dbh->selectrow_array($sql) }; 5627 if ( $EVAL_ERROR ) { 5628 PTDEBUG && _d($EVAL_ERROR); 5629 $name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306); 5630 } 5631 else { 5632 $sql = q{SHOW VARIABLES LIKE 'port'}; 5633 PTDEBUG && _d($sql); 5634 my (undef, $port) = eval { $dbh->selectrow_array($sql) }; 5635 PTDEBUG && _d('port:', $port); 5636 $name .= $port || ''; 5637 } 5638 } 5639 my $id = md5_hex($name); 5640 5641 PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn)); 5642 5643 return $name, $id; 5644} 5645 5646 5647sub get_uuid { 5648 my $uuid_file = '/.percona-toolkit.uuid'; 5649 foreach my $dir (@vc_dirs) { 5650 my $filename = $dir.$uuid_file; 5651 my $uuid=_read_uuid($filename); 5652 return $uuid if $uuid; 5653 } 5654 5655 my $filename = $ENV{"HOME"} . $uuid_file; 5656 my $uuid = _generate_uuid(); 5657 5658 open(my $fh, '>', $filename) or die "Could not open file '$filename' $!"; 5659 print $fh $uuid; 5660 close $fh; 5661 5662 return $uuid; 5663} 5664 5665sub _generate_uuid { 5666 return sprintf+($}="%04x")."$}-$}-$}-$}-".$}x3,map rand 65537,0..7; 5667} 5668 5669sub _read_uuid { 5670 my $filename = shift; 5671 my $fh; 5672 5673 eval { 5674 open($fh, '<:encoding(UTF-8)', $filename); 5675 }; 5676 return if ($EVAL_ERROR); 5677 5678 my $uuid; 5679 eval { $uuid = <$fh>; }; 5680 return if ($EVAL_ERROR); 5681 5682 chomp $uuid; 5683 return $uuid; 5684} 5685 5686 5687sub pingback { 5688 my (%args) = @_; 5689 my @required_args = qw(url instances); 5690 foreach my $arg ( @required_args ) { 5691 die "I need a $arg arugment" unless $args{$arg}; 5692 } 5693 my $url = $args{url}; 5694 my $instances = $args{instances}; 5695 5696 my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 ); 5697 5698 my $response = $ua->request('GET', $url); 5699 PTDEBUG && _d('Server response:', Dumper($response)); 5700 die "No response from GET $url" 5701 if !$response; 5702 die("GET on $url returned HTTP status $response->{status}; expected 200\n", 5703 ($response->{content} || '')) if $response->{status} != 200; 5704 die("GET on $url did not return any programs to check") 5705 if !$response->{content}; 5706 5707 my $items = parse_server_response( 5708 response => $response->{content} 5709 ); 5710 die "Failed to parse server requested programs: $response->{content}" 5711 if !scalar keys %$items; 5712 5713 my $versions = get_versions( 5714 items => $items, 5715 instances => $instances, 5716 ); 5717 die "Failed to get any program versions; should have at least gotten Perl" 5718 if !scalar keys %$versions; 5719 5720 my $client_content = encode_client_response( 5721 items => $items, 5722 versions => $versions, 5723 general_id => get_uuid(), 5724 ); 5725 5726 my $client_response = { 5727 headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, 5728 content => $client_content, 5729 }; 5730 PTDEBUG && _d('Client response:', Dumper($client_response)); 5731 5732 $response = $ua->request('POST', $url, $client_response); 5733 PTDEBUG && _d('Server suggestions:', Dumper($response)); 5734 die "No response from POST $url $client_response" 5735 if !$response; 5736 die "POST $url returned HTTP status $response->{status}; expected 200" 5737 if $response->{status} != 200; 5738 5739 return unless $response->{content}; 5740 5741 $items = parse_server_response( 5742 response => $response->{content}, 5743 split_vars => 0, 5744 ); 5745 die "Failed to parse server suggestions: $response->{content}" 5746 if !scalar keys %$items; 5747 my @suggestions = map { $_->{vars} } 5748 sort { $a->{item} cmp $b->{item} } 5749 values %$items; 5750 5751 return \@suggestions; 5752} 5753 5754sub encode_client_response { 5755 my (%args) = @_; 5756 my @required_args = qw(items versions general_id); 5757 foreach my $arg ( @required_args ) { 5758 die "I need a $arg arugment" unless $args{$arg}; 5759 } 5760 my ($items, $versions, $general_id) = @args{@required_args}; 5761 5762 my @lines; 5763 foreach my $item ( sort keys %$items ) { 5764 next unless exists $versions->{$item}; 5765 if ( ref($versions->{$item}) eq 'HASH' ) { 5766 my $mysql_versions = $versions->{$item}; 5767 for my $id ( sort keys %$mysql_versions ) { 5768 push @lines, join(';', $id, $item, $mysql_versions->{$id}); 5769 } 5770 } 5771 else { 5772 push @lines, join(';', $general_id, $item, $versions->{$item}); 5773 } 5774 } 5775 5776 my $client_response = join("\n", @lines) . "\n"; 5777 return $client_response; 5778} 5779 5780sub parse_server_response { 5781 my (%args) = @_; 5782 my @required_args = qw(response); 5783 foreach my $arg ( @required_args ) { 5784 die "I need a $arg arugment" unless $args{$arg}; 5785 } 5786 my ($response) = @args{@required_args}; 5787 5788 my %items = map { 5789 my ($item, $type, $vars) = split(";", $_); 5790 if ( !defined $args{split_vars} || $args{split_vars} ) { 5791 $vars = [ split(",", ($vars || '')) ]; 5792 } 5793 $item => { 5794 item => $item, 5795 type => $type, 5796 vars => $vars, 5797 }; 5798 } split("\n", $response); 5799 5800 PTDEBUG && _d('Items:', Dumper(\%items)); 5801 5802 return \%items; 5803} 5804 5805my %sub_for_type = ( 5806 os_version => \&get_os_version, 5807 perl_version => \&get_perl_version, 5808 perl_module_version => \&get_perl_module_version, 5809 mysql_variable => \&get_mysql_variable, 5810); 5811 5812sub valid_item { 5813 my ($item) = @_; 5814 return unless $item; 5815 if ( !exists $sub_for_type{ $item->{type} } ) { 5816 PTDEBUG && _d('Invalid type:', $item->{type}); 5817 return 0; 5818 } 5819 return 1; 5820} 5821 5822sub get_versions { 5823 my (%args) = @_; 5824 my @required_args = qw(items); 5825 foreach my $arg ( @required_args ) { 5826 die "I need a $arg arugment" unless $args{$arg}; 5827 } 5828 my ($items) = @args{@required_args}; 5829 5830 my %versions; 5831 foreach my $item ( values %$items ) { 5832 next unless valid_item($item); 5833 eval { 5834 my $version = $sub_for_type{ $item->{type} }->( 5835 item => $item, 5836 instances => $args{instances}, 5837 ); 5838 if ( $version ) { 5839 chomp $version unless ref($version); 5840 $versions{$item->{item}} = $version; 5841 } 5842 }; 5843 if ( $EVAL_ERROR ) { 5844 PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR); 5845 } 5846 } 5847 5848 return \%versions; 5849} 5850 5851 5852sub get_os_version { 5853 if ( $OSNAME eq 'MSWin32' ) { 5854 require Win32; 5855 return Win32::GetOSDisplayName(); 5856 } 5857 5858 chomp(my $platform = `uname -s`); 5859 PTDEBUG && _d('platform:', $platform); 5860 return $OSNAME unless $platform; 5861 5862 chomp(my $lsb_release 5863 = `which lsb_release 2>/dev/null | awk '{print \$1}'` || ''); 5864 PTDEBUG && _d('lsb_release:', $lsb_release); 5865 5866 my $release = ""; 5867 5868 if ( $platform eq 'Linux' ) { 5869 if ( -f "/etc/fedora-release" ) { 5870 $release = `cat /etc/fedora-release`; 5871 } 5872 elsif ( -f "/etc/redhat-release" ) { 5873 $release = `cat /etc/redhat-release`; 5874 } 5875 elsif ( -f "/etc/system-release" ) { 5876 $release = `cat /etc/system-release`; 5877 } 5878 elsif ( $lsb_release ) { 5879 $release = `$lsb_release -ds`; 5880 } 5881 elsif ( -f "/etc/lsb-release" ) { 5882 $release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`; 5883 $release =~ s/^\w+="([^"]+)".+/$1/; 5884 } 5885 elsif ( -f "/etc/debian_version" ) { 5886 chomp(my $rel = `cat /etc/debian_version`); 5887 $release = "Debian $rel"; 5888 if ( -f "/etc/apt/sources.list" ) { 5889 chomp(my $code_name = `awk '/^deb/ {print \$3}' /etc/apt/sources.list | awk -F/ '{print \$1}'| awk 'BEGIN {FS="|"} {print \$1}' | sort | uniq -c | sort -rn | head -n1 | awk '{print \$2}'`); 5890 $release .= " ($code_name)" if $code_name; 5891 } 5892 } 5893 elsif ( -f "/etc/os-release" ) { # openSUSE 5894 chomp($release = `grep PRETTY_NAME /etc/os-release`); 5895 $release =~ s/^PRETTY_NAME="(.+)"$/$1/; 5896 } 5897 elsif ( `ls /etc/*release 2>/dev/null` ) { 5898 if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) { 5899 $release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`; 5900 } 5901 else { 5902 $release = `cat /etc/*release | head -n1`; 5903 } 5904 } 5905 } 5906 elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) { 5907 my $rel = `uname -r`; 5908 $release = "$platform $rel"; 5909 } 5910 elsif ( $platform eq "SunOS" ) { 5911 my $rel = `head -n1 /etc/release` || `uname -r`; 5912 $release = "$platform $rel"; 5913 } 5914 5915 if ( !$release ) { 5916 PTDEBUG && _d('Failed to get the release, using platform'); 5917 $release = $platform; 5918 } 5919 chomp($release); 5920 5921 $release =~ s/^"|"$//g; 5922 5923 PTDEBUG && _d('OS version =', $release); 5924 return $release; 5925} 5926 5927sub get_perl_version { 5928 my (%args) = @_; 5929 my $item = $args{item}; 5930 return unless $item; 5931 5932 my $version = sprintf '%vd', $PERL_VERSION; 5933 PTDEBUG && _d('Perl version', $version); 5934 return $version; 5935} 5936 5937sub get_perl_module_version { 5938 my (%args) = @_; 5939 my $item = $args{item}; 5940 return unless $item; 5941 5942 my $var = '$' . $item->{item} . '::VERSION'; 5943 my $version = eval "use $item->{item}; $var;"; 5944 PTDEBUG && _d('Perl version for', $var, '=', $version); 5945 return $version; 5946} 5947 5948sub get_mysql_variable { 5949 return get_from_mysql( 5950 show => 'VARIABLES', 5951 @_, 5952 ); 5953} 5954 5955sub get_from_mysql { 5956 my (%args) = @_; 5957 my $show = $args{show}; 5958 my $item = $args{item}; 5959 my $instances = $args{instances}; 5960 return unless $show && $item; 5961 5962 if ( !$instances || !@$instances ) { 5963 PTDEBUG && _d('Cannot check', $item, 5964 'because there are no MySQL instances'); 5965 return; 5966 } 5967 5968 if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') { 5969 @{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}}; 5970 } 5971 5972 5973 my @versions; 5974 my %version_for; 5975 foreach my $instance ( @$instances ) { 5976 next unless $instance->{id}; # special system instance has id=0 5977 my $dbh = $instance->{dbh}; 5978 local $dbh->{FetchHashKeyName} = 'NAME_lc'; 5979 my $sql = qq/SHOW $show/; 5980 PTDEBUG && _d($sql); 5981 my $rows = $dbh->selectall_hashref($sql, 'variable_name'); 5982 5983 my @versions; 5984 foreach my $var ( @{$item->{vars}} ) { 5985 $var = lc($var); 5986 my $version = $rows->{$var}->{value}; 5987 PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version, 5988 'on', $instance->{name}); 5989 push @versions, $version; 5990 } 5991 $version_for{ $instance->{id} } = join(' ', @versions); 5992 } 5993 5994 return \%version_for; 5995} 5996 5997sub _d { 5998 my ($package, undef, $line) = caller 0; 5999 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 6000 map { defined $_ ? $_ : 'undef' } 6001 @_; 6002 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 6003} 6004 60051; 6006} 6007# ########################################################################### 6008# End VersionCheck package 6009# ########################################################################### 6010 6011# ########################################################################### 6012# This is a combination of modules and programs in one -- a runnable module. 6013# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last 6014# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition. 6015# 6016# Check at the end of this package for the call to main() which actually runs 6017# the program. 6018# ########################################################################### 6019package pt_archiver; 6020 6021use utf8; 6022use English qw(-no_match_vars); 6023use List::Util qw(max); 6024use IO::File; 6025use sigtrap qw(handler finish untrapped normal-signals); 6026use Time::HiRes qw(gettimeofday sleep time); 6027use Data::Dumper; 6028$Data::Dumper::Indent = 1; 6029$Data::Dumper::Quotekeys = 0; 6030 6031use Percona::Toolkit; 6032use constant PTDEBUG => $ENV{PTDEBUG} || 0; 6033 6034# Global variables; as few as possible. 6035my $oktorun = 1; 6036my $txn_cnt = 0; 6037my $cnt = 0; 6038my $can_retry = 1; 6039my $archive_fh; 6040my $get_sth; 6041my ( $OUT_OF_RETRIES, $ROLLED_BACK, $ALL_IS_WELL ) = ( 0, -1, 1 ); 6042my ( $src, $dst ); 6043my $pxc_version = '0'; 6044my $fields_separated_by = "\t"; 6045my $optionally_enclosed_by; 6046 6047# Holds the arguments for the $sth's bind variables, so it can be re-tried 6048# easily. 6049my @beginning_of_txn; 6050my $q = new Quoter; 6051 6052sub main { 6053 local @ARGV = @_; # set global ARGV for this package 6054 6055 # Reset global vars else tests, which run this tool as a module, 6056 # may encounter weird results. 6057 $oktorun = 1; 6058 $txn_cnt = 0; 6059 $cnt = 0; 6060 $can_retry = 1; 6061 $archive_fh = undef; 6062 $get_sth = undef; 6063 ($src, $dst) = (undef, undef); 6064 @beginning_of_txn = (); 6065 undef *trace; 6066 ($OUT_OF_RETRIES, $ROLLED_BACK, $ALL_IS_WELL ) = (0, -1, 1); 6067 6068 6069 # ######################################################################## 6070 # Get configuration information. 6071 # ######################################################################## 6072 my $o = new OptionParser(); 6073 $o->get_specs(); 6074 $o->get_opts(); 6075 6076 my $dp = $o->DSNParser(); 6077 $dp->prop('set-vars', $o->set_vars()); 6078 6079 # Frequently used options. 6080 $src = $o->get('source'); 6081 $dst = $o->get('dest'); 6082 my $sentinel = $o->get('sentinel'); 6083 my $bulk_del = $o->get('bulk-delete'); 6084 my $commit_each = $o->get('commit-each'); 6085 my $limit = $o->get('limit'); 6086 my $archive_file = $o->get('file'); 6087 my $txnsize = $o->get('txn-size'); 6088 my $quiet = $o->get('quiet'); 6089 my $got_charset = $o->get('charset'); 6090 6091 # First things first: if --stop was given, create the sentinel file. 6092 if ( $o->get('stop') ) { 6093 my $sentinel_fh = IO::File->new($sentinel, ">>") 6094 or die "Cannot open $sentinel: $OS_ERROR\n"; 6095 print $sentinel_fh "Remove this file to permit pt-archiver to run\n" 6096 or die "Cannot write to $sentinel: $OS_ERROR\n"; 6097 close $sentinel_fh 6098 or die "Cannot close $sentinel: $OS_ERROR\n"; 6099 print STDOUT "Successfully created file $sentinel\n" 6100 unless $quiet; 6101 return 0; 6102 } 6103 6104 # Generate a filename with sprintf-like formatting codes. 6105 if ( $archive_file ) { 6106 my @time = localtime(); 6107 my %fmt = ( 6108 d => sprintf('%02d', $time[3]), 6109 H => sprintf('%02d', $time[2]), 6110 i => sprintf('%02d', $time[1]), 6111 m => sprintf('%02d', $time[4] + 1), 6112 s => sprintf('%02d', $time[0]), 6113 Y => $time[5] + 1900, 6114 D => $src && $src->{D} ? $src->{D} : '', 6115 t => $src && $src->{t} ? $src->{t} : '', 6116 ); 6117 $archive_file =~ s/%([dHimsYDt])/$fmt{$1}/g; 6118 } 6119 6120 6121 if ( !$o->got('help') ) { 6122 $o->save_error("--source DSN requires a 't' (table) part") 6123 unless $src->{t}; 6124 6125 if ( $dst ) { 6126 # Ensure --source and --dest don't point to the same place 6127 my $same = 1; 6128 foreach my $arg ( qw(h P D t S) ) { 6129 if ( defined $src->{$arg} && defined $dst->{$arg} 6130 && $src->{$arg} ne $dst->{$arg} ) { 6131 $same = 0; 6132 last; 6133 } 6134 } 6135 if ( $same ) { 6136 $o->save_error("--source and --dest refer to the same table"); 6137 } 6138 } 6139 if ( $o->get('bulk-insert') ) { 6140 $o->save_error("--bulk-insert is meaningless without a destination") 6141 unless $dst; 6142 $bulk_del = 1; # VERY IMPORTANT for safety. 6143 } 6144 if ( $bulk_del && $limit < 2 ) { 6145 $o->save_error("--bulk-delete is meaningless with --limit 1"); 6146 } 6147 if ( $o->got('purge') && $o->got('no-delete') ) { 6148 $o->save_error("--purge and --no-delete are mutually exclusive"); 6149 } 6150 } 6151 6152 if ( $bulk_del || $o->get('bulk-insert') ) { 6153 $o->set('commit-each', 1); 6154 } 6155 6156 $o->usage_or_errors(); 6157 6158 # ######################################################################## 6159 # If --pid, check it first since we'll die if it already exits. 6160 # ######################################################################## 6161 my $daemon; 6162 if ( $o->get('pid') ) { 6163 # We're not daemoninzing, it just handles PID stuff. Keep $daemon 6164 # in the the scope of main() because when it's destroyed it automatically 6165 # removes the PID file. 6166 $daemon = new Daemon(o=>$o); 6167 $daemon->make_PID_file(); 6168 } 6169 6170 # ######################################################################## 6171 # Set up statistics. 6172 # ######################################################################## 6173 my %statistics = (); 6174 my $stat_start; 6175 6176 if ( $o->get('statistics') ) { 6177 my $start = gettimeofday(); 6178 my $obs_cost = gettimeofday() - $start; # cost of observation 6179 6180 *trace = sub { 6181 my ( $thing, $sub ) = @_; 6182 my $start = gettimeofday(); 6183 $sub->(); 6184 $statistics{$thing . '_time'} 6185 += (gettimeofday() - $start - $obs_cost); 6186 ++$statistics{$thing . '_count'}; 6187 $stat_start ||= $start; 6188 } 6189 } 6190 else { # Generate a version that doesn't do any timing 6191 *trace = sub { 6192 my ( $thing, $sub ) = @_; 6193 $sub->(); 6194 } 6195 } 6196 6197 # ######################################################################## 6198 # Inspect DB servers and tables. 6199 # ######################################################################## 6200 6201 my $tp = new TableParser(Quoter => $q); 6202 foreach my $table ( grep { $_ } ($src, $dst) ) { 6203 my $ac = !$txnsize && !$commit_each; 6204 if ( !defined $table->{p} && $o->get('ask-pass') ) { 6205 $table->{p} = OptionParser::prompt_noecho("Enter password: "); 6206 } 6207 my $dbh = $dp->get_dbh( 6208 $dp->get_cxn_params($table), { AutoCommit => $ac }); 6209 PTDEBUG && _d('Inspecting table on', $dp->as_string($table)); 6210 6211 # Set options that can enable removing data on the master 6212 # and archiving it on the slaves. 6213 if ( $table->{a} ) { 6214 $dbh->do("USE $table->{a}"); 6215 } 6216 if ( $table->{b} ) { 6217 $dbh->do("SET SQL_LOG_BIN=0"); 6218 } 6219 6220 my ($dbh_version) = $dbh->selectrow_array("SELECT version()"); 6221 #if ($dbh_version =~ m/^(\d+\.\d+)\.\d+.*/ && $1 ge '8.0' && !$o->get('charset')) { 6222 if ($dbh_version =~ m/^(\d+\.\d+)\.\d+.*/ && $1 ge '8.0') { 6223 PTDEBUG && _d("MySQL 8.0+ detected and charset was not specified.\n Setting character_set_client = utf8mb4 and --charset=utf8"); 6224 $dbh->do('/*!40101 SET character_set_connection = utf8mb4 */;'); 6225 $o->set('charset', 'utf8'); 6226 } 6227 6228 $table->{dbh} = $dbh; 6229 $table->{irot} = get_irot($dbh); 6230 6231 $can_retry = $can_retry && !$table->{irot}; 6232 6233 $table->{db_tbl} = $q->quote( 6234 map { $_ =~ s/(^`|`$)//g; $_; } 6235 grep { $_ } 6236 ( $table->{D}, $table->{t} ) 6237 ); 6238 6239 # Create objects for archivable and dependency handling, BEFORE getting 6240 # the tbl structure (because the object might do some setup, including 6241 # creating the table to be archived). 6242 if ( $table->{m} ) { 6243 eval "require $table->{m}"; 6244 die $EVAL_ERROR if $EVAL_ERROR; 6245 6246 trace('plugin_start', sub { 6247 $table->{plugin} = $table->{m}->new( 6248 dbh => $table->{dbh}, 6249 db => $table->{D}, 6250 tbl => $table->{t}, 6251 OptionParser => $o, 6252 DSNParser => $dp, 6253 Quoter => $q, 6254 ); 6255 }); 6256 } 6257 6258 $table->{info} = $tp->parse( 6259 $tp->get_create_table( $dbh, $table->{D}, $table->{t} )); 6260 6261 if ( $o->get('check-charset') ) { 6262 my $sql = 'SELECT CONCAT(/*!40100 @@session.character_set_connection, */ "")'; 6263 PTDEBUG && _d($sql); 6264 my ($dbh_charset) = $table->{dbh}->selectrow_array($sql); 6265 6266 if ( ($dbh_charset || "") ne ($table->{info}->{charset} || "") && 6267 !($dbh_charset eq "utf8mb4" && ($table->{info}->{charset} || "") eq ("utf8")) 6268 ) { 6269 $src->{dbh}->disconnect() if $src && $src->{dbh}; 6270 $dst->{dbh}->disconnect() if $dst && $dst->{dbh}; 6271 die "Character set mismatch: " 6272 . ($src && $table eq $src ? "--source " : "--dest ") 6273 . "DSN uses " . ($dbh_charset || "") 6274 . ", table uses " . ($table->{info}->{charset} || "") 6275 . ". You can disable this check by specifying " 6276 . "--no-check-charset.\n"; 6277 } 6278 } 6279 } 6280 6281 if ( $o->get('primary-key-only') 6282 && !exists $src->{info}->{keys}->{PRIMARY} ) { 6283 $src->{dbh}->disconnect(); 6284 $dst->{dbh}->disconnect() if $dst && $dst->{dbh}; 6285 die "--primary-key-only was specified by the --source table " 6286 . "$src->{db_tbl} does not have a PRIMARY KEY"; 6287 } 6288 6289 if ( $dst && $o->get('check-columns') ) { 6290 my @not_in_src = grep { 6291 !$src->{info}->{is_col}->{$_} 6292 } @{$dst->{info}->{cols}}; 6293 if ( @not_in_src ) { 6294 $src->{dbh}->disconnect(); 6295 $dst->{dbh}->disconnect() if $dst && $dst->{dbh}; 6296 die "The following columns exist in --dest but not --source: " 6297 . join(', ', @not_in_src) 6298 . "\n"; 6299 } 6300 my @not_in_dst = grep { 6301 !$dst->{info}->{is_col}->{$_} 6302 } @{$src->{info}->{cols}}; 6303 if ( @not_in_dst ) { 6304 $src->{dbh}->disconnect(); 6305 $dst->{dbh}->disconnect() if $dst && $dst->{dbh}; 6306 die "The following columns exist in --source but not --dest: " 6307 . join(', ', @not_in_dst) 6308 . "\n"; 6309 } 6310 } 6311 6312 # ######################################################################## 6313 # Get lag dbh. 6314 # ######################################################################## 6315 my @lag_dbh; 6316 my $ms; 6317 if ( $o->get('check-slave-lag') ) { 6318 my $dsn_defaults = $dp->parse_options($o); 6319 my $lag_slaves_dsn = $o->get('check-slave-lag'); 6320 $ms = new MasterSlave( 6321 OptionParser => $o, 6322 DSNParser => $dp, 6323 Quoter => $q, 6324 channel => $o->get('channel'), 6325 ); 6326 # we get each slave's connection handler (and its id, for debug and reporting) 6327 for my $slave (@$lag_slaves_dsn) { 6328 my $dsn = $dp->parse($slave, $dsn_defaults); 6329 my $lag_dbh = $dp->get_dbh($dp->get_cxn_params($dsn), { AutoCommit => 1 }); 6330 my $lag_id = $ms->short_host($dsn); 6331 push @lag_dbh , {'dbh' => $lag_dbh, 'id' => $lag_id} 6332 } 6333 } 6334 6335 # ####################################################################### 6336 # Check if it's a cluster and if so get version 6337 # Create FlowControlWaiter object if max-flow-ctl was specified and 6338 # PXC version supports it 6339 # ####################################################################### 6340 6341 my $flow_ctl; 6342 if ( $src && $src->{dbh} && Cxn::is_cluster_node($src->{dbh}) ) { 6343 $pxc_version = VersionParser->new($src->{'dbh'}); 6344 if ( $o->got('max-flow-ctl') ) { 6345 if ( $pxc_version < '5.6' ) { 6346 die "Option '--max-flow-ctl' is only available for PXC version 5.6 " 6347 . "or higher." 6348 } else { 6349 $flow_ctl = new FlowControlWaiter( 6350 node => $src->{'dbh'}, 6351 max_flow_ctl => $o->get('max-flow-ctl'), 6352 oktorun => sub { return $oktorun }, 6353 sleep => sub { sleep($o->get('check-interval')) }, 6354 simple_progress => $o->got('progress') ? 1 : 0, 6355 ); 6356 } 6357 } 6358 } 6359 6360 if ( $src && $src->{dbh} && !Cxn::is_cluster_node($src->{dbh}) && $o->got('max-flow-ctl') ) { 6361 die "Option '--max-flow-ctl' is for use with PXC clusters." 6362 } 6363 6364 # ######################################################################## 6365 # Set up general plugin. 6366 # ######################################################################## 6367 my $plugin; 6368 if ( $o->get('plugin') ) { 6369 eval "require " . $o->get('plugin'); 6370 die $EVAL_ERROR if $EVAL_ERROR; 6371 $plugin = $o->get('plugin')->new( 6372 src => $src, 6373 dst => $dst, 6374 opts => $o, 6375 ); 6376 } 6377 6378 # ######################################################################## 6379 # Design SQL statements. 6380 # ######################################################################## 6381 my $dbh = $src->{dbh}; 6382 my $nibbler = new TableNibbler( 6383 TableParser => $tp, 6384 Quoter => $q, 6385 ); 6386 my ($first_sql, $next_sql, $del_sql, $ins_sql); 6387 my ($sel_stmt, $ins_stmt, $del_stmt); 6388 my (@asc_slice, @sel_slice, @del_slice, @bulkdel_slice, @ins_slice); 6389 my @sel_cols = $o->get('columns') ? @{$o->get('columns')} # Explicit 6390 : $o->get('primary-key-only') ? @{$src->{info}->{keys}->{PRIMARY}->{cols}} 6391 : @{$src->{info}->{cols}}; # All 6392 PTDEBUG && _d("sel cols: ", @sel_cols); 6393 6394 $del_stmt = $nibbler->generate_del_stmt( 6395 tbl_struct => $src->{info}, 6396 cols => \@sel_cols, 6397 index => $o->get('primary-key-only') ? 'PRIMARY' : $src->{i}, 6398 ); 6399 @del_slice = @{$del_stmt->{slice}}; 6400 6401 # Generate statement for ascending index, if desired 6402 if ( !$o->get('no-ascend') ) { 6403 $sel_stmt = $nibbler->generate_asc_stmt( 6404 tbl_struct => $src->{info}, 6405 cols => $del_stmt->{cols}, 6406 index => $del_stmt->{index}, 6407 asc_first => $o->get('ascend-first'), 6408 # A plugin might prevent rows in the source from being deleted 6409 # when doing single delete, but it cannot prevent rows from 6410 # being deleted when doing a bulk delete. 6411 asc_only => $o->get('no-delete') ? 1 6412 : $src->{m} ? ($o->get('bulk-delete') ? 0 : 1) 6413 : 0, 6414 ) 6415 } 6416 else { 6417 $sel_stmt = { 6418 cols => $del_stmt->{cols}, 6419 index => undef, 6420 where => '1=1', 6421 slice => [], # No-ascend = no bind variables in the WHERE clause. 6422 scols => [], # No-ascend = no bind variables in the WHERE clause. 6423 }; 6424 } 6425 @asc_slice = @{$sel_stmt->{slice}}; 6426 @sel_slice = 0..$#sel_cols; 6427 6428 $first_sql 6429 = 'SELECT' . ( $o->get('high-priority-select') ? ' HIGH_PRIORITY' : '' ) 6430 . ' /*!40001 SQL_NO_CACHE */ ' 6431 . join(',', map { $q->quote($_) } @{$sel_stmt->{cols}} ) 6432 . " FROM $src->{db_tbl}" 6433 . ( $sel_stmt->{index} 6434 ? ((VersionParser->new($dbh) >= '4.0.9' ? " FORCE" : " USE") 6435 . " INDEX(`$sel_stmt->{index}`)") 6436 : '') 6437 . " WHERE (".$o->get('where').")"; 6438 6439 if ( $o->get('safe-auto-increment') 6440 && $sel_stmt->{index} 6441 && scalar(@{$src->{info}->{keys}->{$sel_stmt->{index}}->{cols}}) == 1 6442 && $src->{info}->{is_autoinc}->{ 6443 $src->{info}->{keys}->{$sel_stmt->{index}}->{cols}->[0] 6444 } 6445 ) { 6446 my $col = $q->quote($sel_stmt->{scols}->[0]); 6447 my ($val) = $dbh->selectrow_array("SELECT MAX($col) FROM $src->{db_tbl}"); 6448 $first_sql .= " AND ($col < " . $q->quote_val($val) . ")"; 6449 } 6450 6451 $next_sql = $first_sql; 6452 if ( !$o->get('no-ascend') ) { 6453 $next_sql .= " AND $sel_stmt->{where}"; 6454 } 6455 6456 # Obtain index cols so we can order them when ascending 6457 # this ensures returned sets are disjoint when ran on partitioned tables 6458 # issue 1376561 6459 my $index_cols; 6460 if ( $sel_stmt->{index} && $src->{info}->{keys}->{$sel_stmt->{index}}->{cols} ) { 6461 $index_cols = join(",",map { "`$_`" } @{$src->{info}->{keys}->{$sel_stmt->{index}}->{cols}}); 6462 } 6463 6464 foreach my $thing ( $first_sql, $next_sql ) { 6465 $thing .= " ORDER BY $index_cols" if $index_cols; 6466 $thing .= " LIMIT $limit"; 6467 if ( $o->get('for-update') ) { 6468 $thing .= ' FOR UPDATE'; 6469 } 6470 elsif ( $o->get('share-lock') ) { 6471 $thing .= ' LOCK IN SHARE MODE'; 6472 } 6473 } 6474 6475 PTDEBUG && _d("Index for DELETE:", $del_stmt->{index}); 6476 if ( !$bulk_del ) { 6477 # The LIMIT might be 1 here, because even though a SELECT can return 6478 # many rows, an INSERT only does one at a time. It would not be safe to 6479 # iterate over a SELECT that was LIMIT-ed to 500 rows, read and INSERT 6480 # one, and then delete with a LIMIT of 500. Only one row would be written 6481 # to the file; only one would be INSERT-ed at the destination. But 6482 # LIMIT 1 is actually only needed when the index is not unique 6483 # (http://code.google.com/p/maatkit/issues/detail?id=1166). 6484 $del_sql = 'DELETE' 6485 . ($o->get('low-priority-delete') ? ' LOW_PRIORITY' : '') 6486 . ($o->get('quick-delete') ? ' QUICK' : '') 6487 . " FROM $src->{db_tbl} WHERE $del_stmt->{where}"; 6488 6489 if ( $src->{info}->{keys}->{$del_stmt->{index}}->{is_unique} ) { 6490 PTDEBUG && _d("DELETE index is unique; LIMIT 1 is not needed"); 6491 } 6492 else { 6493 PTDEBUG && _d("Adding LIMIT 1 to DELETE because DELETE index " 6494 . "is not unique"); 6495 $del_sql .= " LIMIT 1"; 6496 } 6497 } 6498 else { 6499 # Unless, of course, it's a bulk DELETE, in which case the 500 rows have 6500 # already been INSERT-ed. 6501 my $asc_stmt = $nibbler->generate_asc_stmt( 6502 tbl_struct => $src->{info}, 6503 cols => $del_stmt->{cols}, 6504 index => $del_stmt->{index}, 6505 asc_first => 0, 6506 ); 6507 $del_sql = 'DELETE' 6508 . ($o->get('low-priority-delete') ? ' LOW_PRIORITY' : '') 6509 . ($o->get('quick-delete') ? ' QUICK' : '') 6510 . " FROM $src->{db_tbl} WHERE (" 6511 . $asc_stmt->{boundaries}->{'>='} 6512 . ') AND (' . $asc_stmt->{boundaries}->{'<='} 6513 # Unlike the row-at-a-time DELETE, this one must include the user's 6514 # specified WHERE clause and an appropriate LIMIT clause. 6515 . ") AND (".$o->get('where').")" 6516 . ($o->get('bulk-delete-limit') ? " LIMIT $limit" : ""); 6517 @bulkdel_slice = @{$asc_stmt->{slice}}; 6518 } 6519 6520 if ( $dst ) { 6521 $ins_stmt = $nibbler->generate_ins_stmt( 6522 ins_tbl => $dst->{info}, 6523 sel_cols => \@sel_cols, 6524 ); 6525 PTDEBUG && _d("inst stmt: ", Dumper($ins_stmt)); 6526 @ins_slice = @{$ins_stmt->{slice}}; 6527 if ( $o->get('bulk-insert') ) { 6528 $ins_sql = 'LOAD DATA' 6529 . ($o->get('low-priority-insert') ? ' LOW_PRIORITY' : '') 6530 . ' LOCAL INFILE ?' 6531 . ($o->get('replace') ? ' REPLACE' : '') 6532 . ($o->get('ignore') ? ' IGNORE' : '') 6533 . " INTO TABLE $dst->{db_tbl}" 6534 . ($got_charset ? "CHARACTER SET $got_charset" : "") 6535 . "(" 6536 . join(",", map { $q->quote($_) } @{$ins_stmt->{cols}} ) 6537 . ")"; 6538 } 6539 else { 6540 $ins_sql = ($o->get('replace') ? 'REPLACE' : 'INSERT') 6541 . ($o->get('low-priority-insert') ? ' LOW_PRIORITY' : '') 6542 . ($o->get('delayed-insert') ? ' DELAYED' : '') 6543 . ($o->get('ignore') ? ' IGNORE' : '') 6544 . " INTO $dst->{db_tbl}(" 6545 . join(",", map { $q->quote($_) } @{$ins_stmt->{cols}} ) 6546 . ") VALUES (" 6547 . join(",", map { "?" } @{$ins_stmt->{cols}} ) . ")"; 6548 } 6549 } 6550 else { 6551 $ins_sql = ''; 6552 } 6553 6554 if ( PTDEBUG ) { 6555 _d("get first sql:", $first_sql); 6556 _d("get next sql:", $next_sql); 6557 _d("del row sql:", $del_sql); 6558 _d("ins row sql:", $ins_sql); 6559 } 6560 6561 if ( $o->get('dry-run') ) { 6562 if ( !$quiet ) { 6563 print join("\n", grep { $_ } ($archive_file || ''), 6564 $first_sql, $next_sql, 6565 ($o->get('no-delete') ? '' : $del_sql), $ins_sql) 6566 , "\n"; 6567 } 6568 $src->{dbh}->disconnect(); 6569 $dst->{dbh}->disconnect() if $dst && $dst->{dbh}; 6570 return 0; 6571 } 6572 6573 my $get_first = $dbh->prepare($first_sql); 6574 my $get_next = $dbh->prepare($next_sql); 6575 my $del_row = $dbh->prepare($del_sql); 6576 my $ins_row = $dst->{dbh}->prepare($ins_sql) if $dst; # Different $dbh! 6577 6578 # ######################################################################## 6579 # Set MySQL options. 6580 # ######################################################################## 6581 6582 if ( $o->get('skip-foreign-key-checks') ) { 6583 $src->{dbh}->do("/*!40014 SET FOREIGN_KEY_CHECKS=0 */"); 6584 if ( $dst ) { 6585 $dst->{dbh}->do("/*!40014 SET FOREIGN_KEY_CHECKS=0 */"); 6586 } 6587 } 6588 6589 # ######################################################################## 6590 # Set up the plugins 6591 # ######################################################################## 6592 foreach my $table ( $dst, $src ) { 6593 next unless $table && $table->{plugin}; 6594 trace ('before_begin', sub { 6595 $table->{plugin}->before_begin( 6596 cols => \@sel_cols, 6597 allcols => $sel_stmt->{cols}, 6598 ); 6599 }); 6600 } 6601 6602 # ######################################################################## 6603 # Do the version-check 6604 # ######################################################################## 6605 if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) { 6606 VersionCheck::version_check( 6607 force => $o->got('version-check'), 6608 instances => [ 6609 { dbh => $src->{dbh}, dsn => $src->{dsn} }, 6610 ( $dst ? { dbh => $dst->{dbh}, dsn => $dst->{dsn} } : () ), 6611 ], 6612 ); 6613 } 6614 6615 # ######################################################################## 6616 # Start archiving. 6617 # ######################################################################## 6618 my $start = time(); 6619 my $end = $start + ($o->get('run-time') || 0); # When to exit 6620 my $now = $start; 6621 my $last_select_time; # for --sleep-coef 6622 my $retries = $o->get('retries'); 6623 printf("%-19s %7s %7s\n", 'TIME', 'ELAPSED', 'COUNT') 6624 if $o->get('progress') && !$quiet; 6625 printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt) 6626 if $o->get('progress') && !$quiet; 6627 6628 $get_sth = $get_first; # Later it may be assigned $get_next 6629 trace('select', sub { 6630 my $select_start = time; 6631 $get_sth->execute; 6632 $last_select_time = time - $select_start; 6633 $statistics{SELECT} += $get_sth->rows; 6634 }); 6635 my $row = $get_sth->fetchrow_arrayref(); 6636 PTDEBUG && _d("First row: ", Dumper($row), 'rows:', $get_sth->rows); 6637 if ( !$row ) { 6638 $get_sth->finish; 6639 $src->{dbh}->disconnect(); 6640 $dst->{dbh}->disconnect() if $dst && $dst->{dbh}; 6641 return 0; 6642 } 6643 6644 my $charset = $got_charset || ''; 6645 if ($charset eq 'utf8') { 6646 $charset = ":$charset"; 6647 } 6648 elsif ($charset) { 6649 eval { require Encode } 6650 or (PTDEBUG && 6651 _d("Couldn't load Encode: ", $EVAL_ERROR, 6652 "Going to try using the charset ", 6653 "passed in without checking it.")); 6654 # No need to punish a user if they did their 6655 # homework and passed in an official charset, 6656 # rather than an alias. 6657 $charset = ":encoding(" 6658 . (defined &Encode::resolve_alias 6659 ? Encode::resolve_alias($charset) || $charset 6660 : $charset) 6661 . ")"; 6662 } 6663 6664 if ( $charset eq ':utf8' && $DBD::mysql::VERSION lt '4' 6665 && ( $archive_file || $o->get('bulk-insert') ) ) 6666 { 6667 my $plural = ''; 6668 my $files = $archive_file ? '--file' : ''; 6669 if ( $o->get('bulk-insert') ) { 6670 if ($files) { 6671 $plural = 's'; 6672 $files .= $files ? ' and ' : ''; 6673 } 6674 $files .= '--bulk-insert' 6675 } 6676 warn "Setting binmode :raw instead of :utf8 on $files file$plural " 6677 . "because DBD::mysql 3.0007 has a bug with UTF-8. " 6678 . "Verify the $files file$plural, as the bug may lead to " 6679 . "data being double-encoded. Update DBD::mysql to avoid " 6680 . "this warning."; 6681 $charset = ":raw"; 6682 } 6683 6684 # Open the file and print the header to it. 6685 if ( $archive_file ) { 6686 if ($o->got('output-format') && $o->get('output-format') ne 'dump' && $o->get('output-format') ne 'csv') { 6687 warn "Invalid output format:". $o->get('format'); 6688 warn "Using default 'dump' format"; 6689 } elsif ($o->get('output-format') || '' eq 'csv') { 6690 $fields_separated_by = ", "; 6691 $optionally_enclosed_by = '"'; 6692 } 6693 my $need_hdr = $o->get('header') && !-f $archive_file; 6694 $archive_fh = IO::File->new($archive_file, ">>$charset") 6695 or die "Cannot open $charset $archive_file: $OS_ERROR\n"; 6696 binmode STDOUT, ":utf8"; 6697 binmode $archive_fh, ":utf8"; 6698 $archive_fh->autoflush(1) unless $o->get('buffer'); 6699 if ( $need_hdr ) { 6700 print { $archive_fh } '', escape(\@sel_cols, $fields_separated_by, $optionally_enclosed_by), "\n" 6701 or die "Cannot write to $archive_file: $OS_ERROR\n"; 6702 } 6703 } 6704 6705 # Open the bulk insert file, which doesn't get any header info. 6706 my $bulkins_file; 6707 if ( $o->get('bulk-insert') ) { 6708 require File::Temp; 6709 $bulkins_file = File::Temp->new( SUFFIX => 'pt-archiver' ) 6710 or die "Cannot open temp file: $OS_ERROR\n"; 6711 binmode($bulkins_file, $charset) 6712 or die "Cannot set $charset as an encoding for the bulk-insert " 6713 . "file: $OS_ERROR"; 6714 } 6715 6716 # This row is the first row fetched from each 'chunk'. 6717 my $first_row = [ @$row ]; 6718 my $csv_row; 6719 my $flow_ctl_count = 0; 6720 my $lag_count = 0; 6721 my $bulk_count = 0; 6722 6723 ROW: 6724 while ( # Quit if: 6725 $row # There is no data 6726 && $retries >= 0 # or retries are exceeded 6727 && (!$o->get('run-time') || $now < $end) # or time is exceeded 6728 && !-f $sentinel # or the sentinel is set 6729 && $oktorun # or instructed to quit 6730 ) 6731 { 6732 my $lastrow = $row; 6733 6734 if ( !$src->{plugin} 6735 || trace('is_archivable', sub { 6736 $src->{plugin}->is_archivable(row => $row) 6737 }) 6738 ) { 6739 6740 # Do the archiving. Write to the file first since, like the file, 6741 # MyISAM and other tables cannot be rolled back etc. If there is a 6742 # problem, hopefully the data has at least made it to the file. 6743 my $escaped_row; 6744 if ( $archive_fh || $bulkins_file ) { 6745 $escaped_row = escape([@{$row}[@sel_slice]], $fields_separated_by, $optionally_enclosed_by); 6746 } 6747 if ( $archive_fh ) { 6748 trace('print_file', sub { 6749 print $archive_fh $escaped_row, "\n" 6750 or die "Cannot write to $archive_file: $OS_ERROR\n"; 6751 }); 6752 } 6753 6754 # ################################################################### 6755 # This code is for the row-at-a-time archiving functionality. 6756 # ################################################################### 6757 # INSERT must come first, to be as safe as possible. 6758 if ( $dst && !$bulkins_file ) { 6759 my $ins_sth; # Let plugin change which sth is used for the INSERT. 6760 if ( $dst->{plugin} ) { 6761 trace('before_insert', sub { 6762 $dst->{plugin}->before_insert(row => $row); 6763 }); 6764 trace('custom_sth', sub { 6765 $ins_sth = $dst->{plugin}->custom_sth( 6766 row => $row, sql => $ins_sql); 6767 }); 6768 } 6769 $ins_sth ||= $ins_row; # Default to the sth decided before. 6770 my $success = do_with_retries($o, 'inserting', sub { 6771 my $ins_cnt = $ins_sth->execute(@{$row}[@ins_slice]); 6772 PTDEBUG && _d('Inserted', $ins_cnt, 'rows'); 6773 $statistics{INSERT} += $ins_sth->rows; 6774 }); 6775 if ( $success == $OUT_OF_RETRIES ) { 6776 $retries = -1; 6777 last ROW; 6778 } 6779 elsif ( $success == $ROLLED_BACK ) { 6780 --$retries; 6781 next ROW; 6782 } 6783 } 6784 6785 if ( !$bulk_del ) { 6786 # DELETE comes after INSERT for safety. 6787 if ( $src->{plugin} ) { 6788 trace('before_delete', sub { 6789 $src->{plugin}->before_delete(row => $row); 6790 }); 6791 } 6792 if ( !$o->get('no-delete') ) { 6793 my $success = do_with_retries($o, 'deleting', sub { 6794 $del_row->execute(@{$row}[@del_slice]); 6795 PTDEBUG && _d('Deleted', $del_row->rows, 'rows'); 6796 $statistics{DELETE} += $del_row->rows; 6797 }); 6798 if ( $success == $OUT_OF_RETRIES ) { 6799 $retries = -1; 6800 last ROW; 6801 } 6802 elsif ( $success == $ROLLED_BACK ) { 6803 --$retries; 6804 next ROW; 6805 } 6806 } 6807 } 6808 6809 # ################################################################### 6810 # This code is for the bulk archiving functionality. 6811 # ################################################################### 6812 if ( $bulkins_file ) { 6813 trace('print_bulkfile', sub { 6814 print $bulkins_file $escaped_row, "\n" 6815 or die "Cannot write to bulk file: $OS_ERROR\n"; 6816 }); 6817 } 6818 6819 } # row is archivable 6820 6821 $now = time(); 6822 ++$cnt; 6823 ++$txn_cnt; 6824 $retries = $o->get('retries'); 6825 6826 # Possibly flush the file and commit the insert and delete. 6827 commit($o) unless $commit_each; 6828 6829 # Report on progress. 6830 if ( !$quiet && $o->get('progress') && $cnt % $o->get('progress') == 0 ) { 6831 printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt); 6832 } 6833 6834 # Get the next row in this chunk. 6835 # First time through this loop $get_sth is set to $get_first. 6836 # For non-bulk operations this means that rows ($row) are archived 6837 # one-by-one in in the code block above ("row is archivable"). For 6838 # bulk operations, the 2nd to 2nd-to-last rows are ignored and 6839 # only the first row ($first_row) and the last row ($last_row) of 6840 # this chunk are used to do bulk INSERT or DELETE on the range of 6841 # rows between first and last. After the bulk ops, $first_row and 6842 # $last_row are reset to the next chunk. 6843 if ( $get_sth->{Active} ) { # Fetch until exhausted 6844 $row = $get_sth->fetchrow_arrayref(); 6845 } 6846 if ( !$row ) { 6847 PTDEBUG && _d('No more rows in this chunk; doing bulk operations'); 6848 6849 # ################################################################### 6850 # This code is for the bulk archiving functionality. 6851 # ################################################################### 6852 if ( $bulkins_file ) { 6853 $bulkins_file->close() 6854 or die "Cannot close bulk insert file: $OS_ERROR\n"; 6855 my $ins_sth; # Let plugin change which sth is used for the INSERT. 6856 if ( $dst->{plugin} ) { 6857 trace('before_bulk_insert', sub { 6858 $dst->{plugin}->before_bulk_insert( 6859 first_row => $first_row, 6860 last_row => $lastrow, 6861 filename => $bulkins_file->filename(), 6862 ); 6863 }); 6864 trace('custom_sth', sub { 6865 $ins_sth = $dst->{plugin}->custom_sth_bulk( 6866 first_row => $first_row, 6867 last_row => $lastrow, 6868 filename => $bulkins_file->filename(), 6869 sql => $ins_sql, 6870 ); 6871 }); 6872 } 6873 $ins_sth ||= $ins_row; # Default to the sth decided before. 6874 my $success = do_with_retries($o, 'bulk_inserting', sub { 6875 $ins_sth->execute($bulkins_file->filename()); 6876 $src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src; 6877 PTDEBUG && _d('Bulk inserted', $del_row->rows, 'rows'); 6878 $statistics{INSERT} += $ins_sth->rows; 6879 }); 6880 if ( $success != $ALL_IS_WELL ) { 6881 $retries = -1; 6882 last ROW; # unlike other places, don't do 'next' 6883 } 6884 } 6885 6886 if ( $bulk_del ) { 6887 if ( $src->{plugin} ) { 6888 trace('before_bulk_delete', sub { 6889 $src->{plugin}->before_bulk_delete( 6890 first_row => $first_row, 6891 last_row => $lastrow, 6892 ); 6893 }); 6894 } 6895 if ( !$o->get('no-delete') ) { 6896 my $success = do_with_retries($o, 'bulk_deleting', sub { 6897 $del_row->execute( 6898 @{$first_row}[@bulkdel_slice], 6899 @{$lastrow}[@bulkdel_slice], 6900 ); 6901 PTDEBUG && _d('Bulk deleted', $del_row->rows, 'rows'); 6902 $statistics{DELETE} += $del_row->rows; 6903 }); 6904 if ( $success != $ALL_IS_WELL ) { 6905 $retries = -1; 6906 last ROW; # unlike other places, don't do 'next' 6907 } 6908 } 6909 } 6910 6911 # ################################################################### 6912 # This code is for normal operation AND bulk operation. 6913 # ################################################################### 6914 commit($o, 1) if $commit_each; 6915 $get_sth = $get_next; 6916 6917 # Sleep between fetching the next chunk of rows. 6918 if( my $sleep_time = $o->get('sleep') ) { 6919 $sleep_time = $last_select_time * $o->get('sleep-coef') 6920 if $o->get('sleep-coef'); 6921 PTDEBUG && _d('Sleeping', $sleep_time); 6922 trace('sleep', sub { 6923 sleep($sleep_time); 6924 }); 6925 } 6926 6927 PTDEBUG && _d('Fetching rows in next chunk'); 6928 trace('select', sub { 6929 my $select_start = time; 6930 $get_sth->execute(@{$lastrow}[@asc_slice]); 6931 $last_select_time = time - $select_start; 6932 PTDEBUG && _d('Fetched', $get_sth->rows, 'rows'); 6933 $statistics{SELECT} += $get_sth->rows; 6934 }); 6935 6936 # Reset $first_row to the first row of this new chunk. 6937 @beginning_of_txn = @{$lastrow}[@asc_slice] unless $txn_cnt; 6938 $row = $get_sth->fetchrow_arrayref(); 6939 $first_row = $row ? [ @$row ] : undef; 6940 6941 if ( $o->get('bulk-insert') ) { 6942 $bulkins_file = File::Temp->new( SUFFIX => 'pt-archiver' ) 6943 or die "Cannot open temp file: $OS_ERROR\n"; 6944 binmode($bulkins_file, $charset) 6945 or die "Cannot set $charset as an encoding for the bulk-insert " 6946 . "file: $OS_ERROR"; 6947 } 6948 } # no next row (do bulk operations) 6949 else { 6950 # keep alive every 100 rows saved to file 6951 # https://bugs.launchpad.net/percona-toolkit/+bug/1452895 6952 if ( $bulk_count++ % 100 == 0 ) { 6953 $src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src; 6954 } 6955 PTDEBUG && _d('Got another row in this chunk'); 6956 } 6957 6958 # Check slave lag and wait if slave is too far behind. 6959 # Do this check every 100 rows 6960 if (@lag_dbh && $lag_count++ % 100 == 0 ) { 6961 foreach my $lag_server (@lag_dbh) { 6962 my $lag_dbh = $lag_server->{'dbh'}; 6963 my $id = $lag_server->{'id'}; 6964 if ( $lag_dbh ) { 6965 my $lag = $ms->get_slave_lag($lag_dbh); 6966 while ( !defined $lag || $lag > $o->get('max-lag') ) { 6967 PTDEBUG && _d("Sleeping: slave lag for server '$id' is", $lag); 6968 if ($o->got('progress')) { 6969 _d("Sleeping: slave lag for server '$id' is", $lag); 6970 } 6971 sleep($o->get('check-interval')); 6972 $lag = $ms->get_slave_lag($lag_dbh); 6973 commit($o, $txnsize || $commit_each); 6974 $src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src; 6975 $dst->{dbh}->do("SELECT 'pt-archiver keepalive'") if $dst; 6976 } 6977 } 6978 } 6979 } 6980 6981 # if it's a cluster, check for flow control every 100 rows 6982 if ( $flow_ctl && $flow_ctl_count++ % 100 == 0) { 6983 $flow_ctl->wait(); 6984 } 6985 6986 } # ROW 6987 PTDEBUG && _d('Done fetching rows'); 6988 6989 # Transactions might still be open, etc 6990 commit($o, $txnsize || $commit_each); 6991 if ( $archive_file && $archive_fh ) { 6992 close $archive_fh 6993 or die "Cannot close $archive_file: $OS_ERROR\n"; 6994 } 6995 6996 if ( !$quiet && $o->get('progress') ) { 6997 printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt); 6998 } 6999 7000 # Tear down the plugins. 7001 foreach my $table ( $dst, $src ) { 7002 next unless $table && $table->{plugin}; 7003 trace('after_finish', sub { 7004 $table->{plugin}->after_finish(); 7005 }); 7006 } 7007 7008 # Run ANALYZE or OPTIMIZE. 7009 if ( $oktorun && ($o->get('analyze') || $o->get('optimize')) ) { 7010 my $action = $o->get('analyze') || $o->get('optimize'); 7011 my $maint = ($o->get('analyze') ? 'ANALYZE' : 'OPTIMIZE') 7012 . ($o->get('local') ? ' /*!40101 NO_WRITE_TO_BINLOG*/' : ''); 7013 if ( $action =~ m/s/i ) { 7014 trace($maint, sub { 7015 $src->{dbh}->do("$maint TABLE $src->{db_tbl}"); 7016 }); 7017 } 7018 if ( $action =~ m/d/i && $dst ) { 7019 trace($maint, sub { 7020 $dst->{dbh}->do("$maint TABLE $dst->{db_tbl}"); 7021 }); 7022 } 7023 } 7024 7025 # ######################################################################## 7026 # Print statistics 7027 # ######################################################################## 7028 if ( $plugin ) { 7029 $plugin->statistics(\%statistics, $stat_start); 7030 } 7031 7032 if ( !$quiet && $o->get('statistics') ) { 7033 my $stat_stop = gettimeofday(); 7034 my $stat_total = $stat_stop - $stat_start; 7035 7036 my $total2 = 0; 7037 my $maxlen = 0; 7038 my %summary; 7039 7040 printf("Started at %s, ended at %s\n", ts($stat_start), ts($stat_stop)); 7041 print("Source: ", $dp->as_string($src), "\n"); 7042 print("Dest: ", $dp->as_string($dst), "\n") if $dst; 7043 print(join("\n", map { "$_ " . ($statistics{$_} || 0) } 7044 qw(SELECT INSERT DELETE)), "\n"); 7045 7046 foreach my $thing ( grep { m/_(count|time)/ } keys %statistics ) { 7047 my ( $action, $type ) = $thing =~ m/^(.*?)_(count|time)$/; 7048 $summary{$action}->{$type} = $statistics{$thing}; 7049 $summary{$action}->{action} = $action; 7050 $maxlen = max($maxlen, length($action)); 7051 # Just in case I get only one type of statistic for a given action (in 7052 # case there was a crash or CTRL-C or something). 7053 $summary{$action}->{time} ||= 0; 7054 $summary{$action}->{count} ||= 0; 7055 } 7056 printf("%-${maxlen}s \%10s %10s %10s\n", qw(Action Count Time Pct)); 7057 my $fmt = "%-${maxlen}s \%10d %10.4f %10.2f\n"; 7058 7059 foreach my $stat ( 7060 reverse sort { $a->{time} <=> $b->{time} } values %summary ) 7061 { 7062 my $pct = $stat->{time} / $stat_total * 100; 7063 printf($fmt, @{$stat}{qw(action count time)}, $pct); 7064 $total2 += $stat->{time}; 7065 } 7066 printf($fmt, 'other', 0, $stat_total - $total2, 7067 ($stat_total - $total2) / $stat_total * 100); 7068 } 7069 7070 # Optionally print the reason for exiting. Do this even if --quiet is 7071 # specified. 7072 if ( $o->get('why-quit') ) { 7073 if ( $retries < 0 ) { 7074 print "Exiting because retries exceeded.\n"; 7075 } 7076 elsif ( $o->get('run-time') && $now >= $end ) { 7077 print "Exiting because time exceeded.\n"; 7078 } 7079 elsif ( -f $sentinel ) { 7080 print "Exiting because sentinel file $sentinel exists.\n"; 7081 } 7082 elsif ( $o->get('statistics') ) { 7083 print "Exiting because there are no more rows.\n"; 7084 } 7085 } 7086 7087 $get_sth->finish() if $get_sth; 7088 $src->{dbh}->disconnect(); 7089 $dst->{dbh}->disconnect() if $dst && $dst->{dbh}; 7090 7091 return 0; 7092} 7093 7094# ############################################################################ 7095# Subroutines. 7096# ############################################################################ 7097 7098# Catches signals so pt-archiver can exit gracefully. 7099sub finish { 7100 my ($signal) = @_; 7101 print STDERR "Exiting on SIG$signal.\n"; 7102 $oktorun = 0; 7103} 7104 7105# Accesses globals, but I wanted the code in one place. 7106sub commit { 7107 my ( $o, $force ) = @_; 7108 my $txnsize = $o->get('txn-size'); 7109 if ( $force || ($txnsize && $txn_cnt && $cnt % $txnsize == 0) ) { 7110 if ( $o->get('buffer') && $archive_fh ) { 7111 my $archive_file = $o->get('file'); 7112 trace('flush', sub { 7113 $archive_fh->flush or die "Cannot flush $archive_file: $OS_ERROR\n"; 7114 }); 7115 } 7116 if ( $dst ) { 7117 trace('commit', sub { 7118 $dst->{dbh}->commit; 7119 }); 7120 } 7121 trace('commit', sub { 7122 $src->{dbh}->commit; 7123 }); 7124 $txn_cnt = 0; 7125 } 7126} 7127 7128# Repeatedly retries the code until retries runs out, a really bad error 7129# happens, or it succeeds. This sub uses lots of global variables; I only wrote 7130# it to factor out some repeated code. 7131sub do_with_retries { 7132 my ( $o, $doing, $code ) = @_; 7133 my $retries = $o->get('retries'); 7134 my $txnsize = $o->get('txn-size'); 7135 my $success = $OUT_OF_RETRIES; 7136 7137 RETRY: 7138 while ( !$success && $retries >= 0 ) { 7139 eval { 7140 trace($doing, $code); 7141 $success = $ALL_IS_WELL; 7142 }; 7143 if ( $EVAL_ERROR ) { 7144 if ( $EVAL_ERROR =~ m/Lock wait timeout exceeded|Deadlock found/ ) { 7145 if ( 7146 # More than one row per txn 7147 ( 7148 ($txnsize && $txnsize > 1) 7149 || ($o->get('commit-each') && $o->get('limit') > 1) 7150 ) 7151 # Not first row 7152 && $txn_cnt 7153 # And it's not retry-able 7154 && (!$can_retry || $EVAL_ERROR =~ m/Deadlock/) 7155 ) { 7156 # The txn, which is more than 1 statement, was rolled back. 7157 last RETRY; 7158 } 7159 else { 7160 # Only one statement had trouble, and the rest of the txn was 7161 # not rolled back. The statement can be retried. 7162 --$retries; 7163 } 7164 } 7165 else { 7166 die $EVAL_ERROR; 7167 } 7168 } 7169 } 7170 7171 if ( $success != $ALL_IS_WELL ) { 7172 # Must throw away everything and start the transaction over. 7173 if ( $retries >= 0 ) { 7174 warn "Deadlock or non-retryable lock wait while $doing; " 7175 . "rolling back $txn_cnt rows.\n"; 7176 $success = $ROLLED_BACK; 7177 } 7178 else { 7179 warn "Exhausted retries while $doing; rolling back $txn_cnt rows.\n"; 7180 $success = $OUT_OF_RETRIES; 7181 } 7182 $get_sth->finish; 7183 trace('rollback', sub { 7184 $dst->{dbh}->rollback; 7185 }); 7186 trace('rollback', sub { 7187 $src->{dbh}->rollback; 7188 }); 7189 # I wish: $archive_fh->rollback 7190 trace('select', sub { 7191 $get_sth->execute(@beginning_of_txn); 7192 }); 7193 $cnt -= $txn_cnt; 7194 $txn_cnt = 0; 7195 } 7196 return $success; 7197} 7198 7199# Formats a row the same way SELECT INTO OUTFILE does by default. This is 7200# described in the LOAD DATA INFILE section of the MySQL manual, 7201# http://dev.mysql.com/doc/refman/5.0/en/load-data.html 7202sub escape { 7203 my ($row, $fields_separated_by, $optionally_enclosed_by) = @_; 7204 $fields_separated_by ||= "\t"; 7205 $optionally_enclosed_by ||= ''; 7206 7207 return join($fields_separated_by, map { 7208 s/([\t\n\\])/\\$1/g if defined $_; # Escape tabs etc 7209 my $s = defined $_ ? $_ : '\N'; # NULL = \N 7210 # var & ~var will return 0 only for numbers 7211 if ($s !~ /^[0-9,.E]+$/ && $optionally_enclosed_by eq '"') { 7212 $s =~ s/([^\\])"/$1\\"/g; 7213 $s = $optionally_enclosed_by."$s".$optionally_enclosed_by; 7214 } 7215 # $_ =~ s/([^\\])"/$1\\"/g if ($_ !~ /^[0-9,.E]+$/ && $optionally_enclosed_by eq '"'); 7216 # $_ = $optionally_enclosed_by && ($_ & ~$_) ? $optionally_enclosed_by."$_".$optionally_enclosed_by : $_; 7217 chomp $s; 7218 $s; 7219 } @$row); 7220 7221} 7222 7223sub ts { 7224 my ( $time ) = @_; 7225 my ( $sec, $min, $hour, $mday, $mon, $year ) 7226 = localtime($time); 7227 $mon += 1; 7228 $year += 1900; 7229 return sprintf("%d-%02d-%02dT%02d:%02d:%02d", 7230 $year, $mon, $mday, $hour, $min, $sec); 7231} 7232 7233sub get_irot { 7234 my ( $dbh ) = @_; 7235 return 1 unless VersionParser->new($dbh) >= '5.0.13'; 7236 my $rows = $dbh->selectall_arrayref( 7237 "show variables like 'innodb_rollback_on_timeout'", 7238 { Slice => {} }); 7239 return 0 unless $rows; 7240 return @$rows && $rows->[0]->{Value} ne 'OFF'; 7241} 7242 7243sub _d { 7244 my ($package, undef, $line) = caller 0; 7245 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 7246 map { defined $_ ? $_ : 'undef' } 7247 @_; 7248 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 7249} 7250 7251# ############################################################################ 7252# Run the program. 7253# ############################################################################ 7254if ( !caller ) { exit main(@ARGV); } 7255 72561; # Because this is a module as well as a script. 7257 7258# ############################################################################ 7259# Documentation. 7260# ############################################################################ 7261 7262=pod 7263 7264=head1 NAME 7265 7266pt-archiver - Archive rows from a MySQL table into another table or a file. 7267 7268=head1 SYNOPSIS 7269 7270Usage: pt-archiver [OPTIONS] --source DSN --where WHERE 7271 7272pt-archiver nibbles records from a MySQL table. The --source and --dest 7273arguments use DSN syntax; if COPY is yes, --dest defaults to the key's value 7274from --source. 7275 7276Examples: 7277 7278Archive all rows from oltp_server to olap_server and to a file: 7279 7280 pt-archiver --source h=oltp_server,D=test,t=tbl --dest h=olap_server \ 7281 --file '/var/log/archive/%Y-%m-%d-%D.%t' \ 7282 --where "1=1" --limit 1000 --commit-each 7283 7284Purge (delete) orphan rows from child table: 7285 7286 pt-archiver --source h=host,D=db,t=child --purge \ 7287 --where 'NOT EXISTS(SELECT * FROM parent WHERE col=child.col)' 7288 7289=head1 RISKS 7290 7291Percona Toolkit is mature, proven in the real world, and well tested, 7292but all database tools can pose a risk to the system and the database 7293server. Before using this tool, please: 7294 7295=over 7296 7297=item * Read the tool's documentation 7298 7299=item * Review the tool's known L<"BUGS"> 7300 7301=item * Test the tool on a non-production server 7302 7303=item * Backup your production server and verify the backups 7304 7305=back 7306 7307=head1 DESCRIPTION 7308 7309pt-archiver is the tool I use to archive tables as described in 7310L<http://tinyurl.com/mysql-archiving>. The goal is a low-impact, forward-only 7311job to nibble old data out of the table without impacting OLTP queries much. 7312You can insert the data into another table, which need not be on the same 7313server. You can also write it to a file in a format suitable for LOAD DATA 7314INFILE. Or you can do neither, in which case it's just an incremental DELETE. 7315 7316pt-archiver is extensible via a plugin mechanism. You can inject your own 7317code to add advanced archiving logic that could be useful for archiving 7318dependent data, applying complex business rules, or building a data warehouse 7319during the archiving process. 7320 7321You need to choose values carefully for some options. The most important are 7322L<"--limit">, L<"--retries">, and L<"--txn-size">. 7323 7324The strategy is to find the first row(s), then scan some index forward-only to 7325find more rows efficiently. Each subsequent query should not scan the entire 7326table; it should seek into the index, then scan until it finds more archivable 7327rows. Specifying the index with the 'i' part of the L<"--source"> argument can 7328be crucial for this; use L<"--dry-run"> to examine the generated queries and be 7329sure to EXPLAIN them to see if they are efficient (most of the time you probably 7330want to scan the PRIMARY key, which is the default). Even better, examine the 7331difference in the Handler status counters before and after running the query, 7332and make sure it is not scanning the whole table every query. 7333 7334You can disable the seek-then-scan optimizations partially or wholly with 7335L<"--no-ascend"> and L<"--ascend-first">. Sometimes this may be more efficient 7336for multi-column keys. Be aware that pt-archiver is built to start at the 7337beginning of the index it chooses and scan it forward-only. This might result 7338in long table scans if you're trying to nibble from the end of the table by an 7339index other than the one it prefers. See L<"--source"> and read the 7340documentation on the C<i> part if this applies to you. 7341 7342=head1 Percona XtraDB Cluster 7343 7344pt-archiver works with Percona XtraDB Cluster (PXC) 5.5.28-23.7 and newer, 7345but there are three limitations you should consider before archiving on 7346a cluster: 7347 7348=over 7349 7350=item Error on commit 7351 7352pt-archiver does not check for error when it commits transactions. 7353Commits on PXC can fail, but the tool does not yet check for or retry the 7354transaction when this happens. If it happens, the tool will die. 7355 7356=item MyISAM tables 7357 7358Archiving MyISAM tables works, but MyISAM support in PXC is still 7359experimental at the time of this release. There are several known bugs with 7360PXC, MyISAM tables, and C<AUTO_INCREMENT> columns. Therefore, you must ensure 7361that archiving will not directly or indirectly result in the use of default 7362C<AUTO_INCREMENT> values for a MyISAM table. For example, this happens with 7363L<"--dest"> if L<"--columns"> is used and the C<AUTO_INCREMENT> column is not 7364included. The tool does not check for this! 7365 7366=item Non-cluster options 7367 7368Certain options may or may not work. For example, if a cluster node 7369is not also a slave, then L<"--check-slave-lag"> does not work. And since PXC 7370tables are usually InnoDB, but InnoDB doesn't support C<INSERT DELAYED>, then 7371L<"--delayed-insert"> does not work. Other options may also not work, but 7372the tool does not check them, therefore you should test archiving on a test 7373cluster before archiving on your real cluster. 7374 7375=back 7376 7377=head1 OUTPUT 7378 7379If you specify L<"--progress">, the output is a header row, plus status output 7380at intervals. Each row in the status output lists the current date and time, 7381how many seconds pt-archiver has been running, and how many rows it has 7382archived. 7383 7384If you specify L<"--statistics">, C<pt-archiver> outputs timing and other 7385information to help you identify which part of your archiving process takes the 7386most time. 7387 7388=head1 ERROR-HANDLING 7389 7390pt-archiver tries to catch signals and exit gracefully; for example, if you 7391send it SIGTERM (Ctrl-C on UNIX-ish systems), it will catch the signal, print a 7392message about the signal, and exit fairly normally. It will not execute 7393L<"--analyze"> or L<"--optimize">, because these may take a long time to finish. 7394It will run all other code normally, including calling after_finish() on any 7395plugins (see L<"EXTENDING">). 7396 7397In other words, a signal, if caught, will break out of the main archiving 7398loop and skip optimize/analyze. 7399 7400=head1 OPTIONS 7401 7402Specify at least one of L<"--dest">, L<"--file">, or L<"--purge">. 7403 7404L<"--ignore"> and L<"--replace"> are mutually exclusive. 7405 7406L<"--txn-size"> and L<"--commit-each"> are mutually exclusive. 7407 7408L<"--low-priority-insert"> and L<"--delayed-insert"> are mutually exclusive. 7409 7410L<"--share-lock"> and L<"--for-update"> are mutually exclusive. 7411 7412L<"--analyze"> and L<"--optimize"> are mutually exclusive. 7413 7414L<"--no-ascend"> and L<"--no-delete"> are mutually exclusive. 7415 7416DSN values in L<"--dest"> default to values from L<"--source"> if COPY is yes. 7417 7418=over 7419 7420=item --analyze 7421 7422type: string 7423 7424Run ANALYZE TABLE afterwards on L<"--source"> and/or L<"--dest">. 7425 7426Runs ANALYZE TABLE after finishing. The argument is an arbitrary string. If it 7427contains the letter 's', the source will be analyzed. If it contains 'd', the 7428destination will be analyzed. You can specify either or both. For example, the 7429following will analyze both: 7430 7431 --analyze=ds 7432 7433See L<http://dev.mysql.com/doc/en/analyze-table.html> for details on ANALYZE 7434TABLE. 7435 7436=item --ascend-first 7437 7438Ascend only first column of index. 7439 7440If you do want to use the ascending index optimization (see L<"--no-ascend">), 7441but do not want to incur the overhead of ascending a large multi-column index, 7442you can use this option to tell pt-archiver to ascend only the leftmost column 7443of the index. This can provide a significant performance boost over not 7444ascending the index at all, while avoiding the cost of ascending the whole 7445index. 7446 7447See L<"EXTENDING"> for a discussion of how this interacts with plugins. 7448 7449=item --ask-pass 7450 7451Prompt for a password when connecting to MySQL. 7452 7453=item --buffer 7454 7455Buffer output to L<"--file"> and flush at commit. 7456 7457Disables autoflushing to L<"--file"> and flushes L<"--file"> to disk only when a 7458transaction commits. This typically means the file is block-flushed by the 7459operating system, so there may be some implicit flushes to disk between 7460commits as well. The default is to flush L<"--file"> to disk after every row. 7461 7462The danger is that a crash might cause lost data. 7463 7464The performance increase I have seen from using L<"--buffer"> is around 5 to 15 7465percent. Your mileage may vary. 7466 7467=item --bulk-delete 7468 7469Delete each chunk with a single statement (implies L<"--commit-each">). 7470 7471Delete each chunk of rows in bulk with a single C<DELETE> statement. The 7472statement deletes every row between the first and last row of the chunk, 7473inclusive. It implies L<"--commit-each">, since it would be a bad idea to 7474C<INSERT> rows one at a time and commit them before the bulk C<DELETE>. 7475 7476The normal method is to delete every row by its primary key. Bulk deletes might 7477be a lot faster. B<They also might not be faster> if you have a complex 7478C<WHERE> clause. 7479 7480This option completely defers all C<DELETE> processing until the chunk of rows 7481is finished. If you have a plugin on the source, its C<before_delete> method 7482will not be called. Instead, its C<before_bulk_delete> method is called later. 7483 7484B<WARNING>: if you have a plugin on the source that sometimes doesn't return 7485true from C<is_archivable()>, you should use this option only if you understand 7486what it does. If the plugin instructs C<pt-archiver> not to archive a row, 7487it will still be deleted by the bulk delete! 7488 7489=item --[no]bulk-delete-limit 7490 7491default: yes 7492 7493Add L<"--limit"> to L<"--bulk-delete"> statement. 7494 7495This is an advanced option and you should not disable it unless you know what 7496you are doing and why! By default, L<"--bulk-delete"> appends a L<"--limit"> 7497clause to the bulk delete SQL statement. In certain cases, this clause can be 7498omitted by specifying C<--no-bulk-delete-limit>. L<"--limit"> must still be 7499specified. 7500 7501=item --bulk-insert 7502 7503Insert each chunk with LOAD DATA INFILE (implies L<"--bulk-delete"> L<"--commit-each">). 7504 7505Insert each chunk of rows with C<LOAD DATA LOCAL INFILE>. This may be much 7506faster than inserting a row at a time with C<INSERT> statements. It is 7507implemented by creating a temporary file for each chunk of rows, and writing the 7508rows to this file instead of inserting them. When the chunk is finished, it 7509uploads the rows. 7510 7511To protect the safety of your data, this option forces bulk deletes to be used. 7512It would be unsafe to delete each row as it is found, before inserting the rows 7513into the destination first. Forcing bulk deletes guarantees that the deletion 7514waits until the insertion is successful. 7515 7516The L<"--low-priority-insert">, L<"--replace">, and L<"--ignore"> options work 7517with this option, but L<"--delayed-insert"> does not. 7518 7519If C<LOAD DATA LOCAL INFILE> throws an error in the lines of C<The used 7520command is not allowed with this MySQL version>, refer to the documentation 7521for the C<L> DSN option. 7522 7523=item --channel 7524 7525type: string 7526 7527Channel name used when connected to a server using replication channels. 7528Suppose you have two masters, master_a at port 12345, master_b at port 1236 and 7529a slave connected to both masters using channels chan_master_a and chan_master_b. 7530If you want to run pt-archiver to syncronize the slave against master_a, pt-archiver 7531won't be able to determine what's the correct master since SHOW SLAVE STATUS 7532will return 2 rows. In this case, you can use --channel=chan_master_a to specify 7533the channel name to use in the SHOW SLAVE STATUS command. 7534 7535=item --charset 7536 7537short form: -A; type: string 7538 7539Default character set. If the value is utf8, sets Perl's binmode on 7540STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET 7541NAMES UTF8 after connecting to MySQL. Any other value sets binmode on STDOUT 7542without the utf8 layer, and runs SET NAMES after connecting to MySQL. 7543 7544Note that only charsets as known by MySQL are recognized; So for example, 7545"UTF8" will work, but "UTF-8" will not. 7546 7547See also L<"--[no]check-charset">. 7548 7549=item --[no]check-charset 7550 7551default: yes 7552 7553Ensure connection and table character sets are the same. Disabling this check 7554may cause text to be erroneously converted from one character set to another 7555(usually from utf8 to latin1) which may cause data loss or mojibake. Disabling 7556this check may be useful or necessary when character set conversions are 7557intended. 7558 7559=item --[no]check-columns 7560 7561default: yes 7562 7563Ensure L<"--source"> and L<"--dest"> have same columns. 7564 7565Enabled by default; causes pt-archiver to check that the source and destination 7566tables have the same columns. It does not check column order, data type, etc. 7567It just checks that all columns in the source exist in the destination and 7568vice versa. If there are any differences, pt-archiver will exit with an 7569error. 7570 7571To disable this check, specify --no-check-columns. 7572 7573=item --check-interval 7574 7575type: time; default: 1s 7576 7577If L<"--check-slave-lag"> is given, this defines how long the tool pauses each 7578 time it discovers that a slave is lagging. 7579 This check is performed every 100 rows. 7580 7581=item --check-slave-lag 7582 7583type: string; repeatable: yes 7584 7585Pause archiving until the specified DSN's slave lag is less than L<"--max-lag">. 7586This option can be specified multiple times for checking more than one slave. 7587 7588=item --columns 7589 7590short form: -c; type: array 7591 7592Comma-separated list of columns to archive. 7593 7594Specify a comma-separated list of columns to fetch, write to the file, and 7595insert into the destination table. If specified, pt-archiver ignores other 7596columns unless it needs to add them to the C<SELECT> statement for ascending an 7597index or deleting rows. It fetches and uses these extra columns internally, but 7598does not write them to the file or to the destination table. It I<does> pass 7599them to plugins. 7600 7601See also L<"--primary-key-only">. 7602 7603=item --commit-each 7604 7605Commit each set of fetched and archived rows (disables L<"--txn-size">). 7606 7607Commits transactions and flushes L<"--file"> after each set of rows has been 7608archived, before fetching the next set of rows, and before sleeping if 7609L<"--sleep"> is specified. Disables L<"--txn-size">; use L<"--limit"> to 7610control the transaction size with L<"--commit-each">. 7611 7612This option is useful as a shortcut to make L<"--limit"> and L<"--txn-size"> the 7613same value, but more importantly it avoids transactions being held open while 7614searching for more rows. For example, imagine you are archiving old rows from 7615the beginning of a very large table, with L<"--limit"> 1000 and L<"--txn-size"> 76161000. After some period of finding and archiving 1000 rows at a time, 7617pt-archiver finds the last 999 rows and archives them, then executes the next 7618SELECT to find more rows. This scans the rest of the table, but never finds any 7619more rows. It has held open a transaction for a very long time, only to 7620determine it is finished anyway. You can use L<"--commit-each"> to avoid this. 7621 7622=item --config 7623 7624type: Array 7625 7626Read this comma-separated list of config files; if specified, this must be the 7627first option on the command line. 7628 7629=item --database 7630 7631short form: -D; type: string 7632 7633Connect to this database. 7634 7635=item --delayed-insert 7636 7637Add the DELAYED modifier to INSERT statements. 7638 7639Adds the DELAYED modifier to INSERT or REPLACE statements. See 7640L<http://dev.mysql.com/doc/en/insert.html> for details. 7641 7642=item --dest 7643 7644type: DSN 7645 7646DSN specifying the table to archive to. 7647 7648This item specifies a table into which pt-archiver will insert rows 7649archived from L<"--source">. It uses the same key=val argument format as 7650L<"--source">. Most missing values default to the same values as 7651L<"--source">, so you don't have to repeat options that are the same in 7652L<"--source"> and L<"--dest">. Use the L<"--help"> option to see which values 7653are copied from L<"--source">. 7654 7655B<WARNING>: Using a default options file (F) DSN option that defines a 7656socket for L<"--source"> causes pt-archiver to connect to L<"--dest"> using 7657that socket unless another socket for L<"--dest"> is specified. This 7658means that pt-archiver may incorrectly connect to L<"--source"> when it 7659connects to L<"--dest">. For example: 7660 7661 --source F=host1.cnf,D=db,t=tbl --dest h=host2 7662 7663When pt-archiver connects to L<"--dest">, host2, it will connect via the 7664L<"--source">, host1, socket defined in host1.cnf. 7665 7666=item --dry-run 7667 7668Print queries and exit without doing anything. 7669 7670Causes pt-archiver to exit after printing the filename and SQL statements 7671it will use. 7672 7673=item --file 7674 7675type: string 7676 7677File to archive to, with DATE_FORMAT()-like formatting. 7678 7679Filename to write archived rows to. A subset of MySQL's DATE_FORMAT() 7680formatting codes are allowed in the filename, as follows: 7681 7682 %d Day of the month, numeric (01..31) 7683 %H Hour (00..23) 7684 %i Minutes, numeric (00..59) 7685 %m Month, numeric (01..12) 7686 %s Seconds (00..59) 7687 %Y Year, numeric, four digits 7688 7689You can use the following extra format codes too: 7690 7691 %D Database name 7692 %t Table name 7693 7694Example: 7695 7696 --file '/var/log/archive/%Y-%m-%d-%D.%t' 7697 7698The file's contents are in the same format used by SELECT INTO OUTFILE, as 7699documented in the MySQL manual: rows terminated by newlines, columns 7700terminated by tabs, NULL characters are represented by C<\N>, and special 7701characters are escaped by C<\>. This lets you reload a file with LOAD DATA 7702INFILE's default settings. 7703 7704If you want a column header at the top of the file, see L<"--header">. The file 7705is auto-flushed by default; see L<"--buffer">. 7706 7707=item --for-update 7708 7709Adds the FOR UPDATE modifier to SELECT statements. 7710 7711For details, see L<http://dev.mysql.com/doc/en/innodb-locking-reads.html>. 7712 7713=item --header 7714 7715Print column header at top of L<"--file">. 7716 7717Writes column names as the first line in the file given by L<"--file">. If the 7718file exists, does not write headers; this keeps the file loadable with LOAD 7719DATA INFILE in case you append more output to it. 7720 7721=item --help 7722 7723Show help and exit. 7724 7725=item --high-priority-select 7726 7727Adds the HIGH_PRIORITY modifier to SELECT statements. 7728 7729See L<http://dev.mysql.com/doc/en/select.html> for details. 7730 7731=item --host 7732 7733short form: -h; type: string 7734 7735Connect to host. 7736 7737=item --ignore 7738 7739Use IGNORE for INSERT statements. 7740 7741Causes INSERTs into L<"--dest"> to be INSERT IGNORE. 7742 7743=item --limit 7744 7745type: int; default: 1 7746 7747Number of rows to fetch and archive per statement. 7748 7749Limits the number of rows returned by the SELECT statements that retrieve rows 7750to archive. Default is one row. It may be more efficient to increase the 7751limit, but be careful if you are archiving sparsely, skipping over many rows; 7752this can potentially cause more contention with other queries, depending on the 7753storage engine, transaction isolation level, and options such as 7754L<"--for-update">. 7755 7756=item --local 7757 7758Do not write OPTIMIZE or ANALYZE queries to binlog. 7759 7760Adds the NO_WRITE_TO_BINLOG modifier to ANALYZE and OPTIMIZE queries. See 7761L<"--analyze"> for details. 7762 7763=item --low-priority-delete 7764 7765Adds the LOW_PRIORITY modifier to DELETE statements. 7766 7767See L<http://dev.mysql.com/doc/en/delete.html> for details. 7768 7769=item --low-priority-insert 7770 7771Adds the LOW_PRIORITY modifier to INSERT or REPLACE statements. 7772 7773See L<http://dev.mysql.com/doc/en/insert.html> for details. 7774 7775=item --max-flow-ctl 7776 7777type: float 7778 7779Somewhat similar to --max-lag but for PXC clusters. 7780Check average time cluster spent pausing for Flow Control and make tool pause if 7781it goes over the percentage indicated in the option. 7782Default is no Flow Control checking. 7783This option is available for PXC versions 5.6 or higher. 7784 7785=item --max-lag 7786 7787type: time; default: 1s 7788 7789Pause archiving if the slave given by L<"--check-slave-lag"> lags. 7790 7791This option causes pt-archiver to look at the slave every time it's about 7792to fetch another row. If the slave's lag is greater than the option's value, 7793or if the slave isn't running (so its lag is NULL), pt-table-checksum sleeps 7794for L<"--check-interval"> seconds and then looks at the lag again. It repeats 7795until the slave is caught up, then proceeds to fetch and archive the row. 7796 7797This option may eliminate the need for L<"--sleep"> or L<"--sleep-coef">. 7798 7799=item --no-ascend 7800 7801Do not use ascending index optimization. 7802 7803The default ascending-index optimization causes C<pt-archiver> to optimize 7804repeated C<SELECT> queries so they seek into the index where the previous query 7805ended, then scan along it, rather than scanning from the beginning of the table 7806every time. This is enabled by default because it is generally a good strategy 7807for repeated accesses. 7808 7809Large, multiple-column indexes may cause the WHERE clause to be complex enough 7810that this could actually be less efficient. Consider for example a four-column 7811PRIMARY KEY on (a, b, c, d). The WHERE clause to start where the last query 7812ended is as follows: 7813 7814 WHERE (a > ?) 7815 OR (a = ? AND b > ?) 7816 OR (a = ? AND b = ? AND c > ?) 7817 OR (a = ? AND b = ? AND c = ? AND d >= ?) 7818 7819Populating the placeholders with values uses memory and CPU, adds network 7820traffic and parsing overhead, and may make the query harder for MySQL to 7821optimize. A four-column key isn't a big deal, but a ten-column key in which 7822every column allows C<NULL> might be. 7823 7824Ascending the index might not be necessary if you know you are simply removing 7825rows from the beginning of the table in chunks, but not leaving any holes, so 7826starting at the beginning of the table is actually the most efficient thing to 7827do. 7828 7829See also L<"--ascend-first">. See L<"EXTENDING"> for a discussion of how this 7830interacts with plugins. 7831 7832=item --no-delete 7833 7834Do not delete archived rows. 7835 7836Causes C<pt-archiver> not to delete rows after processing them. This disallows 7837L<"--no-ascend">, because enabling them both would cause an infinite loop. 7838 7839If there is a plugin on the source DSN, its C<before_delete> method is called 7840anyway, even though C<pt-archiver> will not execute the delete. See 7841L<"EXTENDING"> for more on plugins. 7842 7843=item --optimize 7844 7845type: string 7846 7847Run OPTIMIZE TABLE afterwards on L<"--source"> and/or L<"--dest">. 7848 7849Runs OPTIMIZE TABLE after finishing. See L<"--analyze"> for the option syntax 7850and L<http://dev.mysql.com/doc/en/optimize-table.html> for details on OPTIMIZE 7851TABLE. 7852 7853=item --output-format 7854 7855type: string 7856 7857Used with L<"--file"> to specify the output format. 7858 7859Valid formats are: 7860 7861- dump: MySQL dump format using tabs as field separator (default) 7862 7863- csv : Dump rows using ',' as separator and optionally enclosing fields by '"'. 7864 This format is equivalent to FIELDS TERMINATED BY ',' OPTIONALLY ENCLOSED BY '"'. 7865 7866=item --password 7867 7868short form: -p; type: string 7869 7870Password to use when connecting. 7871If password contains commas they must be escaped with a backslash: "exam\,ple" 7872 7873=item --pid 7874 7875type: string 7876 7877Create the given PID file. The tool won't start if the PID file already 7878exists and the PID it contains is different than the current PID. However, 7879if the PID file exists and the PID it contains is no longer running, the 7880tool will overwrite the PID file with the current PID. The PID file is 7881removed automatically when the tool exits. 7882 7883=item --plugin 7884 7885type: string 7886 7887Perl module name to use as a generic plugin. 7888 7889Specify the Perl module name of a general-purpose plugin. It is currently used 7890only for statistics (see L<"--statistics">) and must have C<new()> and a 7891C<statistics()> method. 7892 7893The C<new( src =E<gt> $src, dst =E<gt> $dst, opts =E<gt> $o )> method gets the source 7894and destination DSNs, and their database connections, just like the 7895connection-specific plugins do. It also gets an OptionParser object (C<$o>) for 7896accessing command-line options (example: C<$o-E<gt>get('purge');>). 7897 7898The C<statistics(\%stats, $time)> method gets a hashref of the statistics 7899collected by the archiving job, and the time the whole job started. 7900 7901=item --port 7902 7903short form: -P; type: int 7904 7905Port number to use for connection. 7906 7907=item --primary-key-only 7908 7909Primary key columns only. 7910 7911A shortcut for specifying L<"--columns"> with the primary key columns. This is 7912an efficiency if you just want to purge rows; it avoids fetching the entire row, 7913when only the primary key columns are needed for C<DELETE> statements. See also 7914L<"--purge">. 7915 7916=item --progress 7917 7918type: int 7919 7920Print progress information every X rows. 7921 7922Prints current time, elapsed time, and rows archived every X rows. 7923 7924=item --purge 7925 7926Purge instead of archiving; allows omitting L<"--file"> and L<"--dest">. 7927 7928Allows archiving without a L<"--file"> or L<"--dest"> argument, which is 7929effectively a purge since the rows are just deleted. 7930 7931If you just want to purge rows, consider specifying the table's primary key 7932columns with L<"--primary-key-only">. This will prevent fetching all columns 7933from the server for no reason. 7934 7935=item --quick-delete 7936 7937Adds the QUICK modifier to DELETE statements. 7938 7939See L<http://dev.mysql.com/doc/en/delete.html> for details. As stated in the 7940documentation, in some cases it may be faster to use DELETE QUICK followed by 7941OPTIMIZE TABLE. You can use L<"--optimize"> for this. 7942 7943=item --quiet 7944 7945short form: -q 7946 7947Do not print any output, such as for L<"--statistics">. 7948 7949Suppresses normal output, including the output of L<"--statistics">, but doesn't 7950suppress the output from L<"--why-quit">. 7951 7952=item --replace 7953 7954Causes INSERTs into L<"--dest"> to be written as REPLACE. 7955 7956=item --retries 7957 7958type: int; default: 1 7959 7960Number of retries per timeout or deadlock. 7961 7962Specifies the number of times pt-archiver should retry when there is an 7963InnoDB lock wait timeout or deadlock. When retries are exhausted, 7964pt-archiver will exit with an error. 7965 7966Consider carefully what you want to happen when you are archiving between a 7967mixture of transactional and non-transactional storage engines. The INSERT to 7968L<"--dest"> and DELETE from L<"--source"> are on separate connections, so they 7969do not actually participate in the same transaction even if they're on the same 7970server. However, pt-archiver implements simple distributed transactions in 7971code, so commits and rollbacks should happen as desired across the two 7972connections. 7973 7974At this time I have not written any code to handle errors with transactional 7975storage engines other than InnoDB. Request that feature if you need it. 7976 7977=item --run-time 7978 7979type: time 7980 7981Time to run before exiting. 7982 7983Optional suffix s=seconds, m=minutes, h=hours, d=days; if no suffix, s is used. 7984 7985=item --[no]safe-auto-increment 7986 7987default: yes 7988 7989Do not archive row with max AUTO_INCREMENT. 7990 7991Adds an extra WHERE clause to prevent pt-archiver from removing the newest 7992row when ascending a single-column AUTO_INCREMENT key. This guards against 7993re-using AUTO_INCREMENT values if the server restarts, and is enabled by 7994default. 7995 7996The extra WHERE clause contains the maximum value of the auto-increment column 7997as of the beginning of the archive or purge job. If new rows are inserted while 7998pt-archiver is running, it will not see them. 7999 8000=item --sentinel 8001 8002type: string; default: /tmp/pt-archiver-sentinel 8003 8004Exit if this file exists. 8005 8006The presence of the file specified by L<"--sentinel"> will cause pt-archiver to 8007stop archiving and exit. The default is /tmp/pt-archiver-sentinel. You 8008might find this handy to stop cron jobs gracefully if necessary. See also 8009L<"--stop">. 8010 8011=item --slave-user 8012 8013type: string 8014 8015Sets the user to be used to connect to the slaves. 8016This parameter allows you to have a different user with less privileges on the 8017slaves but that user must exist on all slaves. 8018 8019=item --slave-password 8020 8021type: string 8022 8023Sets the password to be used to connect to the slaves. 8024It can be used with --slave-user and the password for the user must be the same 8025on all slaves. 8026 8027=item --set-vars 8028 8029type: Array 8030 8031Set the MySQL variables in this comma-separated list of C<variable=value> pairs. 8032 8033By default, the tool sets: 8034 8035=for comment ignore-pt-internal-value 8036MAGIC_set_vars 8037 8038 wait_timeout=10000 8039 8040Variables specified on the command line override these defaults. For 8041example, specifying C<--set-vars wait_timeout=500> overrides the default 8042value of C<10000>. 8043 8044The tool prints a warning and continues if a variable cannot be set. 8045 8046=item --share-lock 8047 8048Adds the LOCK IN SHARE MODE modifier to SELECT statements. 8049 8050See L<http://dev.mysql.com/doc/en/innodb-locking-reads.html>. 8051 8052=item --skip-foreign-key-checks 8053 8054Disables foreign key checks with SET FOREIGN_KEY_CHECKS=0. 8055 8056=item --sleep 8057 8058type: int 8059 8060Sleep time between fetches. 8061 8062Specifies how long to sleep between SELECT statements. Default is not to 8063sleep at all. Transactions are NOT committed, and the L<"--file"> file is NOT 8064flushed, before sleeping. See L<"--txn-size"> to control that. 8065 8066If L<"--commit-each"> is specified, committing and flushing happens before 8067sleeping. 8068 8069=item --sleep-coef 8070 8071type: float 8072 8073Calculate L<"--sleep"> as a multiple of the last SELECT time. 8074 8075If this option is specified, pt-archiver will sleep for the query time of the 8076last SELECT multiplied by the specified coefficient. 8077 8078This is a slightly more sophisticated way to throttle the SELECTs: sleep a 8079varying amount of time between each SELECT, depending on how long the SELECTs 8080are taking. 8081 8082=item --socket 8083 8084short form: -S; type: string 8085 8086Socket file to use for connection. 8087 8088=item --source 8089 8090type: DSN 8091 8092DSN specifying the table to archive from (required). This argument is a DSN. 8093See L<DSN OPTIONS> for the syntax. Most options control how pt-archiver 8094connects to MySQL, but there are some extended DSN options in this tool's 8095syntax. The D, t, and i options select a table to archive: 8096 8097 --source h=my_server,D=my_database,t=my_tbl 8098 8099The a option specifies the database to set as the connection's default with USE. 8100If the b option is true, it disables binary logging with SQL_LOG_BIN. The m 8101option specifies pluggable actions, which an external Perl module can provide. 8102The only required part is the table; other parts may be read from various 8103places in the environment (such as options files). 8104 8105The 'i' part deserves special mention. This tells pt-archiver which index 8106it should scan to archive. This appears in a FORCE INDEX or USE INDEX hint in 8107the SELECT statements used to fetch archivable rows. If you don't specify 8108anything, pt-archiver will auto-discover a good index, preferring a C<PRIMARY 8109KEY> if one exists. In my experience this usually works well, so most of the 8110time you can probably just omit the 'i' part. 8111 8112The index is used to optimize repeated accesses to the table; pt-archiver 8113remembers the last row it retrieves from each SELECT statement, and uses it to 8114construct a WHERE clause, using the columns in the specified index, that should 8115allow MySQL to start the next SELECT where the last one ended, rather than 8116potentially scanning from the beginning of the table with each successive 8117SELECT. If you are using external plugins, please see L<"EXTENDING"> for a 8118discussion of how they interact with ascending indexes. 8119 8120The 'a' and 'b' options allow you to control how statements flow through the 8121binary log. If you specify the 'b' option, binary logging will be disabled on 8122the specified connection. If you specify the 'a' option, the connection will 8123C<USE> the specified database, which you can use to prevent slaves from 8124executing the binary log events with C<--replicate-ignore-db> options. These 8125two options can be used as different methods to achieve the same goal: archive 8126data off the master, but leave it on the slave. For example, you can run a 8127purge job on the master and prevent it from happening on the slave using your 8128method of choice. 8129 8130B<WARNING>: Using a default options file (F) DSN option that defines a 8131socket for L<"--source"> causes pt-archiver to connect to L<"--dest"> using 8132that socket unless another socket for L<"--dest"> is specified. This 8133means that pt-archiver may incorrectly connect to L<"--source"> when it 8134is meant to connect to L<"--dest">. For example: 8135 8136 --source F=host1.cnf,D=db,t=tbl --dest h=host2 8137 8138When pt-archiver connects to L<"--dest">, host2, it will connect via the 8139L<"--source">, host1, socket defined in host1.cnf. 8140 8141=item --statistics 8142 8143Collect and print timing statistics. 8144 8145Causes pt-archiver to collect timing statistics about what it does. These 8146statistics are available to the plugin specified by L<"--plugin"> 8147 8148Unless you specify L<"--quiet">, C<pt-archiver> prints the statistics when it 8149exits. The statistics look like this: 8150 8151 Started at 2008-07-18T07:18:53, ended at 2008-07-18T07:18:53 8152 Source: D=db,t=table 8153 SELECT 4 8154 INSERT 4 8155 DELETE 4 8156 Action Count Time Pct 8157 commit 10 0.1079 88.27 8158 select 5 0.0047 3.87 8159 deleting 4 0.0028 2.29 8160 inserting 4 0.0028 2.28 8161 other 0 0.0040 3.29 8162 8163The first two (or three) lines show times and the source and destination tables. 8164The next three lines show how many rows were fetched, inserted, and deleted. 8165 8166The remaining lines show counts and timing. The columns are the action, the 8167total number of times that action was timed, the total time it took, and the 8168percent of the program's total runtime. The rows are sorted in order of 8169descending total time. The last row is the rest of the time not explicitly 8170attributed to anything. Actions will vary depending on command-line options. 8171 8172If L<"--why-quit"> is given, its behavior is changed slightly. This option 8173causes it to print the reason for exiting even when it's just because there are 8174no more rows. 8175 8176This option requires the standard Time::HiRes module, which is part of core Perl 8177on reasonably new Perl releases. 8178 8179=item --stop 8180 8181Stop running instances by creating the sentinel file. 8182 8183Causes pt-archiver to create the sentinel file specified by L<"--sentinel"> and 8184exit. This should have the effect of stopping all running instances which are 8185watching the same sentinel file. 8186 8187=item --txn-size 8188 8189type: int; default: 1 8190 8191Number of rows per transaction. 8192 8193Specifies the size, in number of rows, of each transaction. Zero disables 8194transactions altogether. After pt-archiver processes this many rows, it 8195commits both the L<"--source"> and the L<"--dest"> if given, and flushes the 8196file given by L<"--file">. 8197 8198This parameter is critical to performance. If you are archiving from a live 8199server, which for example is doing heavy OLTP work, you need to choose a good 8200balance between transaction size and commit overhead. Larger transactions 8201create the possibility of more lock contention and deadlocks, but smaller 8202transactions cause more frequent commit overhead, which can be significant. To 8203give an idea, on a small test set I worked with while writing pt-archiver, a 8204value of 500 caused archiving to take about 2 seconds per 1000 rows on an 8205otherwise quiet MySQL instance on my desktop machine, archiving to disk and to 8206another table. Disabling transactions with a value of zero, which turns on 8207autocommit, dropped performance to 38 seconds per thousand rows. 8208 8209If you are not archiving from or to a transactional storage engine, you may 8210want to disable transactions so pt-archiver doesn't try to commit. 8211 8212=item --user 8213 8214short form: -u; type: string 8215 8216User for login if not current user. 8217 8218=item --version 8219 8220Show version and exit. 8221 8222=item --[no]version-check 8223 8224default: yes 8225 8226Check for the latest version of Percona Toolkit, MySQL, and other programs. 8227 8228This is a standard "check for updates automatically" feature, with two 8229additional features. First, the tool checks its own version and also the 8230versions of the following software: operating system, Percona Monitoring and 8231Management (PMM), MySQL, Perl, MySQL driver for Perl (DBD::mysql), and 8232Percona Toolkit. Second, it checks for and warns about versions with known 8233problems. For example, MySQL 5.5.25 had a critical bug and was re-released 8234as 5.5.25a. 8235 8236A secure connection to Percona's Version Check database server is done to 8237perform these checks. Each request is logged by the server, including software 8238version numbers and unique ID of the checked system. The ID is generated by the 8239Percona Toolkit installation script or when the Version Check database call is 8240done for the first time. 8241 8242Any updates or known problems are printed to STDOUT before the tool's normal 8243output. This feature should never interfere with the normal operation of the 8244tool. 8245 8246For more information, visit L<https://www.percona.com/doc/percona-toolkit/LATEST/version-check.html>. 8247 8248=item --where 8249 8250type: string 8251 8252WHERE clause to limit which rows to archive (required). 8253 8254Specifies a WHERE clause to limit which rows are archived. Do not include the 8255word WHERE. You may need to quote the argument to prevent your shell from 8256interpreting it. For example: 8257 8258 --where 'ts < current_date - interval 90 day' 8259 8260For safety, L<"--where"> is required. If you do not require a WHERE clause, use 8261L<"--where"> 1=1. 8262 8263=item --why-quit 8264 8265Print reason for exiting unless rows exhausted. 8266 8267Causes pt-archiver to print a message if it exits for any reason other than 8268running out of rows to archive. This can be useful if you have a cron job with 8269L<"--run-time"> specified, for example, and you want to be sure pt-archiver is 8270finishing before running out of time. 8271 8272If L<"--statistics"> is given, the behavior is changed slightly. It will print 8273the reason for exiting even when it's just because there are no more rows. 8274 8275This output prints even if L<"--quiet"> is given. That's so you can put 8276C<pt-archiver> in a C<cron> job and get an email if there's an abnormal exit. 8277 8278=back 8279 8280=head1 DSN OPTIONS 8281 8282These DSN options are used to create a DSN. Each option is given like 8283C<option=value>. The options are case-sensitive, so P and p are not the 8284same option. There cannot be whitespace before or after the C<=> and 8285if the value contains whitespace it must be quoted. DSN options are 8286comma-separated. See the L<percona-toolkit> manpage for full details. 8287 8288=over 8289 8290=item * a 8291 8292copy: no 8293 8294Database to USE when executing queries. 8295 8296=item * A 8297 8298dsn: charset; copy: yes 8299 8300Default character set. 8301 8302=item * b 8303 8304copy: no 8305 8306If true, disable binlog with SQL_LOG_BIN. 8307 8308=item * D 8309 8310dsn: database; copy: yes 8311 8312Database that contains the table. 8313 8314=item * F 8315 8316dsn: mysql_read_default_file; copy: yes 8317 8318Only read default options from the given file 8319 8320=item * h 8321 8322dsn: host; copy: yes 8323 8324Connect to host. 8325 8326=item * i 8327 8328copy: yes 8329 8330Index to use. 8331 8332=item * L 8333 8334copy: yes 8335 8336Explicitly enable LOAD DATA LOCAL INFILE. 8337 8338For some reason, some vendors compile libmysql without the 8339--enable-local-infile option, which disables the statement. This can 8340lead to weird situations, like the server allowing LOCAL INFILE, but 8341the client throwing exceptions if it's used. 8342 8343However, as long as the server allows LOAD DATA, clients can easily 8344re-enable it; See L<https://dev.mysql.com/doc/refman/5.0/en/load-data-local.html> 8345and L<http://search.cpan.org/~capttofu/DBD-mysql/lib/DBD/mysql.pm>. 8346This option does exactly that. 8347 8348Although we've not found a case where turning this option leads to errors or 8349differing behavior, to be on the safe side, this option is not 8350on by default. 8351 8352=item * m 8353 8354copy: no 8355 8356Plugin module name. 8357 8358=item * p 8359 8360dsn: password; copy: yes 8361 8362Password to use when connecting. 8363If password contains commas they must be escaped with a backslash: "exam\,ple" 8364 8365=item * P 8366 8367dsn: port; copy: yes 8368 8369Port number to use for connection. 8370 8371=item * S 8372 8373dsn: mysql_socket; copy: yes 8374 8375Socket file to use for connection. 8376 8377=item * t 8378 8379copy: yes 8380 8381Table to archive from/to. 8382 8383=item * u 8384 8385dsn: user; copy: yes 8386 8387User for login if not current user. 8388 8389=back 8390 8391=head1 EXTENDING 8392 8393pt-archiver is extensible by plugging in external Perl modules to handle some 8394logic and/or actions. You can specify a module for both the L<"--source"> and 8395the L<"--dest">, with the 'm' part of the specification. For example: 8396 8397 --source D=test,t=test1,m=My::Module1 --dest m=My::Module2,t=test2 8398 8399This will cause pt-archiver to load the My::Module1 and My::Module2 packages, 8400create instances of them, and then make calls to them during the archiving 8401process. 8402 8403You can also specify a plugin with L<"--plugin">. 8404 8405The module must provide this interface: 8406 8407=over 8408 8409=item new(dbh => $dbh, db => $db_name, tbl => $tbl_name) 8410 8411The plugin's constructor is passed a reference to the database handle, the 8412database name, and table name. The plugin is created just after pt-archiver 8413opens the connection, and before it examines the table given in the arguments. 8414This gives the plugin a chance to create and populate temporary tables, or do 8415other setup work. 8416 8417=item before_begin(cols => \@cols, allcols => \@allcols) 8418 8419This method is called just before pt-archiver begins iterating through rows 8420and archiving them, but after it does all other setup work (examining table 8421structures, designing SQL queries, and so on). This is the only time 8422pt-archiver tells the plugin column names for the rows it will pass the 8423plugin while archiving. 8424 8425The C<cols> argument is the column names the user requested to be archived, 8426either by default or by the L<"--columns"> option. The C<allcols> argument is 8427the list of column names for every row pt-archiver will fetch from the source 8428table. It may fetch more columns than the user requested, because it needs some 8429columns for its own use. When subsequent plugin functions receive a row, it is 8430the full row containing all the extra columns, if any, added to the end. 8431 8432=item is_archivable(row => \@row) 8433 8434This method is called for each row to determine whether it is archivable. This 8435applies only to L<"--source">. The argument is the row itself, as an arrayref. 8436If the method returns true, the row will be archived; otherwise it will be 8437skipped. 8438 8439Skipping a row adds complications for non-unique indexes. Normally 8440pt-archiver uses a WHERE clause designed to target the last processed row as 8441the place to start the scan for the next SELECT statement. If you have skipped 8442the row by returning false from is_archivable(), pt-archiver could get into 8443an infinite loop because the row still exists. Therefore, when you specify a 8444plugin for the L<"--source"> argument, pt-archiver will change its WHERE clause 8445slightly. Instead of starting at "greater than or equal to" the last processed 8446row, it will start "strictly greater than." This will work fine on unique 8447indexes such as primary keys, but it may skip rows (leave holes) on non-unique 8448indexes or when ascending only the first column of an index. 8449 8450C<pt-archiver> will change the clause in the same way if you specify 8451L<"--no-delete">, because again an infinite loop is possible. 8452 8453If you specify the L<"--bulk-delete"> option and return false from this method, 8454C<pt-archiver> may not do what you want. The row won't be archived, but it will 8455be deleted, since bulk deletes operate on ranges of rows and don't know which 8456rows the plugin selected to keep. 8457 8458If you specify the L<"--bulk-insert"> option, this method's return value will 8459influence whether the row is written to the temporary file for the bulk insert, 8460so bulk inserts will work as expected. However, bulk inserts require bulk 8461deletes. 8462 8463=item before_delete(row => \@row) 8464 8465This method is called for each row just before it is deleted. This applies only 8466to L<"--source">. This is a good place for you to handle dependencies, such as 8467deleting things that are foreign-keyed to the row you are about to delete. You 8468could also use this to recursively archive all dependent tables. 8469 8470This plugin method is called even if L<"--no-delete"> is given, but not if 8471L<"--bulk-delete"> is given. 8472 8473=item before_bulk_delete(first_row => \@row, last_row => \@row) 8474 8475This method is called just before a bulk delete is executed. It is similar to 8476the C<before_delete> method, except its arguments are the first and last row of 8477the range to be deleted. It is called even if L<"--no-delete"> is given. 8478 8479=item before_insert(row => \@row) 8480 8481This method is called for each row just before it is inserted. This applies 8482only to L<"--dest">. You could use this to insert the row into multiple tables, 8483perhaps with an ON DUPLICATE KEY UPDATE clause to build summary tables in a data 8484warehouse. 8485 8486This method is not called if L<"--bulk-insert"> is given. 8487 8488=item before_bulk_insert(first_row => \@row, last_row => \@row, filename => bulk_insert_filename) 8489 8490This method is called just before a bulk insert is executed. It is similar to 8491the C<before_insert> method, except its arguments are the first and last row of 8492the range to be deleted. 8493 8494=item custom_sth(row => \@row, sql => $sql) 8495 8496This method is called just before inserting the row, but after 8497L<"before_insert()">. It allows the plugin to specify different C<INSERT> 8498statement if desired. The return value (if any) should be a DBI statement 8499handle. The C<sql> parameter is the SQL text used to prepare the default 8500C<INSERT> statement. This method is not called if you specify 8501L<"--bulk-insert">. 8502 8503If no value is returned, the default C<INSERT> statement handle is used. 8504 8505This method applies only to the plugin specified for L<"--dest">, so if your 8506plugin isn't doing what you expect, check that you've specified it for the 8507destination and not the source. 8508 8509=item custom_sth_bulk(first_row => \@row, last_row => \@row, sql => $sql, filename => $bulk_insert_filename) 8510 8511If you've specified L<"--bulk-insert">, this method is called just before the 8512bulk insert, but after L<"before_bulk_insert()">, and the arguments are 8513different. 8514 8515This method's return value etc is similar to the L<"custom_sth()"> method. 8516 8517=item after_finish() 8518 8519This method is called after pt-archiver exits the archiving loop, commits all 8520database handles, closes L<"--file">, and prints the final statistics, but 8521before pt-archiver runs ANALYZE or OPTIMIZE (see L<"--analyze"> and 8522L<"--optimize">). 8523 8524=back 8525 8526If you specify a plugin for both L<"--source"> and L<"--dest">, pt-archiver 8527constructs, calls before_begin(), and calls after_finish() on the two plugins in 8528the order L<"--source">, L<"--dest">. 8529 8530pt-archiver assumes it controls transactions, and that the plugin will NOT 8531commit or roll back the database handle. The database handle passed to the 8532plugin's constructor is the same handle pt-archiver uses itself. Remember 8533that L<"--source"> and L<"--dest"> are separate handles. 8534 8535A sample module might look like this: 8536 8537 package My::Module; 8538 8539 sub new { 8540 my ( $class, %args ) = @_; 8541 return bless(\%args, $class); 8542 } 8543 8544 sub before_begin { 8545 my ( $self, %args ) = @_; 8546 # Save column names for later 8547 $self->{cols} = $args{cols}; 8548 } 8549 8550 sub is_archivable { 8551 my ( $self, %args ) = @_; 8552 # Do some advanced logic with $args{row} 8553 return 1; 8554 } 8555 8556 sub before_delete {} # Take no action 8557 sub before_insert {} # Take no action 8558 sub custom_sth {} # Take no action 8559 sub after_finish {} # Take no action 8560 8561 1; 8562 8563=head1 ENVIRONMENT 8564 8565The environment variable C<PTDEBUG> enables verbose debugging output to STDERR. 8566To enable debugging and capture all output to a file, run the tool like: 8567 8568 PTDEBUG=1 pt-archiver ... > FILE 2>&1 8569 8570Be careful: debugging output is voluminous and can generate several megabytes 8571of output. 8572 8573=head1 SYSTEM REQUIREMENTS 8574 8575You need Perl, DBI, DBD::mysql, and some core packages that ought to be 8576installed in any reasonably new version of Perl. 8577 8578=head1 BUGS 8579 8580For a list of known bugs, see L<http://www.percona.com/bugs/pt-archiver>. 8581 8582Please report bugs at L<https://jira.percona.com/projects/PT>. 8583Include the following information in your bug report: 8584 8585=over 8586 8587=item * Complete command-line used to run the tool 8588 8589=item * Tool L<"--version"> 8590 8591=item * MySQL version of all servers involved 8592 8593=item * Output from the tool including STDERR 8594 8595=item * Input files (log/dump/config files, etc.) 8596 8597=back 8598 8599If possible, include debugging output by running the tool with C<PTDEBUG>; 8600see L<"ENVIRONMENT">. 8601 8602=head1 DOWNLOADING 8603 8604Visit L<http://www.percona.com/software/percona-toolkit/> to download the 8605latest release of Percona Toolkit. Or, get the latest release from the 8606command line: 8607 8608 wget percona.com/get/percona-toolkit.tar.gz 8609 8610 wget percona.com/get/percona-toolkit.rpm 8611 8612 wget percona.com/get/percona-toolkit.deb 8613 8614You can also get individual tools from the latest release: 8615 8616 wget percona.com/get/TOOL 8617 8618Replace C<TOOL> with the name of any tool. 8619 8620=head1 AUTHORS 8621 8622Baron Schwartz 8623 8624=head1 ACKNOWLEDGMENTS 8625 8626Andrew O'Brien 8627 8628=head1 ABOUT PERCONA TOOLKIT 8629 8630This tool is part of Percona Toolkit, a collection of advanced command-line 8631tools for MySQL developed by Percona. Percona Toolkit was forked from two 8632projects in June, 2011: Maatkit and Aspersa. Those projects were created by 8633Baron Schwartz and primarily developed by him and Daniel Nichter. Visit 8634L<http://www.percona.com/software/> to learn about other free, open-source 8635software from Percona. 8636 8637=head1 COPYRIGHT, LICENSE, AND WARRANTY 8638 8639This program is copyright 2011-2018 Percona LLC and/or its affiliates, 86402007-2011 Baron Schwartz. 8641 8642THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 8643WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 8644MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 8645 8646This program is free software; you can redistribute it and/or modify it under 8647the terms of the GNU General Public License as published by the Free Software 8648Foundation, version 2; OR the Perl Artistic License. On UNIX and similar 8649systems, you can issue `man perlgpl' or `man perlartistic' to read these 8650licenses. 8651 8652You should have received a copy of the GNU General Public License along with 8653this program; if not, write to the Free Software Foundation, Inc., 59 Temple 8654Place, Suite 330, Boston, MA 02111-1307 USA. 8655 8656=head1 VERSION 8657 8658pt-archiver 3.3.0 8659 8660=cut 8661