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 OptionParser 18 Quoter 19 DSNParser 20 Cxn 21 Daemon 22 Transformers 23 HTTP::Micro 24 VersionCheck 25 Runtime 26 )); 27} 28 29# ########################################################################### 30# Percona::Toolkit package 31# This package is a copy without comments from the original. The original 32# with comments and its test file can be found in the Bazaar repository at, 33# lib/Percona/Toolkit.pm 34# t/lib/Percona/Toolkit.t 35# See https://launchpad.net/percona-toolkit for more information. 36# ########################################################################### 37{ 38package Percona::Toolkit; 39 40our $VERSION = '3.3.0'; 41 42use strict; 43use warnings FATAL => 'all'; 44use English qw(-no_match_vars); 45use constant PTDEBUG => $ENV{PTDEBUG} || 0; 46 47use Carp qw(carp cluck); 48use Data::Dumper qw(); 49 50require Exporter; 51our @ISA = qw(Exporter); 52our @EXPORT_OK = qw( 53 have_required_args 54 Dumper 55 _d 56); 57 58sub have_required_args { 59 my ($args, @required_args) = @_; 60 my $have_required_args = 1; 61 foreach my $arg ( @required_args ) { 62 if ( !defined $args->{$arg} ) { 63 $have_required_args = 0; 64 carp "Argument $arg is not defined"; 65 } 66 } 67 cluck unless $have_required_args; # print backtrace 68 return $have_required_args; 69} 70 71sub Dumper { 72 local $Data::Dumper::Indent = 1; 73 local $Data::Dumper::Sortkeys = 1; 74 local $Data::Dumper::Quotekeys = 0; 75 Data::Dumper::Dumper(@_); 76} 77 78sub _d { 79 my ($package, undef, $line) = caller 0; 80 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 81 map { defined $_ ? $_ : 'undef' } 82 @_; 83 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 84} 85 861; 87} 88# ########################################################################### 89# End Percona::Toolkit package 90# ########################################################################### 91 92# ########################################################################### 93# OptionParser package 94# This package is a copy without comments from the original. The original 95# with comments and its test file can be found in the Bazaar repository at, 96# lib/OptionParser.pm 97# t/lib/OptionParser.t 98# See https://launchpad.net/percona-toolkit for more information. 99# ########################################################################### 100{ 101package OptionParser; 102 103use strict; 104use warnings FATAL => 'all'; 105use English qw(-no_match_vars); 106use constant PTDEBUG => $ENV{PTDEBUG} || 0; 107 108use List::Util qw(max); 109use Getopt::Long; 110use Data::Dumper; 111 112my $POD_link_re = '[LC]<"?([^">]+)"?>'; 113 114sub new { 115 my ( $class, %args ) = @_; 116 my @required_args = qw(); 117 foreach my $arg ( @required_args ) { 118 die "I need a $arg argument" unless $args{$arg}; 119 } 120 121 my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/; 122 $program_name ||= $PROGRAM_NAME; 123 my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.'; 124 125 my %attributes = ( 126 'type' => 1, 127 'short form' => 1, 128 'group' => 1, 129 'default' => 1, 130 'cumulative' => 1, 131 'negatable' => 1, 132 'repeatable' => 1, # means it can be specified more than once 133 ); 134 135 my $self = { 136 head1 => 'OPTIONS', # These args are used internally 137 skip_rules => 0, # to instantiate another Option- 138 item => '--(.*)', # Parser obj that parses the 139 attributes => \%attributes, # DSN OPTIONS section. Tools 140 parse_attributes => \&_parse_attribs, # don't tinker with these args. 141 142 %args, 143 144 strict => 1, # disabled by a special rule 145 program_name => $program_name, 146 opts => {}, 147 got_opts => 0, 148 short_opts => {}, 149 defaults => {}, 150 groups => {}, 151 allowed_groups => {}, 152 errors => [], 153 rules => [], # desc of rules for --help 154 mutex => [], # rule: opts are mutually exclusive 155 atleast1 => [], # rule: at least one opt is required 156 disables => {}, # rule: opt disables other opts 157 defaults_to => {}, # rule: opt defaults to value of other opt 158 DSNParser => undef, 159 default_files => [ 160 "/etc/percona-toolkit/percona-toolkit.conf", 161 "/etc/percona-toolkit/$program_name.conf", 162 "$home/.percona-toolkit.conf", 163 "$home/.$program_name.conf", 164 ], 165 types => { 166 string => 's', # standard Getopt type 167 int => 'i', # standard Getopt type 168 float => 'f', # standard Getopt type 169 Hash => 'H', # hash, formed from a comma-separated list 170 hash => 'h', # hash as above, but only if a value is given 171 Array => 'A', # array, similar to Hash 172 array => 'a', # array, similar to hash 173 DSN => 'd', # DSN 174 size => 'z', # size with kMG suffix (powers of 2^10) 175 time => 'm', # time, with an optional suffix of s/h/m/d 176 }, 177 }; 178 179 return bless $self, $class; 180} 181 182sub get_specs { 183 my ( $self, $file ) = @_; 184 $file ||= $self->{file} || __FILE__; 185 my @specs = $self->_pod_to_specs($file); 186 $self->_parse_specs(@specs); 187 188 open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 189 my $contents = do { local $/ = undef; <$fh> }; 190 close $fh; 191 if ( $contents =~ m/^=head1 DSN OPTIONS/m ) { 192 PTDEBUG && _d('Parsing DSN OPTIONS'); 193 my $dsn_attribs = { 194 dsn => 1, 195 copy => 1, 196 }; 197 my $parse_dsn_attribs = sub { 198 my ( $self, $option, $attribs ) = @_; 199 map { 200 my $val = $attribs->{$_}; 201 if ( $val ) { 202 $val = $val eq 'yes' ? 1 203 : $val eq 'no' ? 0 204 : $val; 205 $attribs->{$_} = $val; 206 } 207 } keys %$attribs; 208 return { 209 key => $option, 210 %$attribs, 211 }; 212 }; 213 my $dsn_o = new OptionParser( 214 description => 'DSN OPTIONS', 215 head1 => 'DSN OPTIONS', 216 dsn => 0, # XXX don't infinitely recurse! 217 item => '\* (.)', # key opts are a single character 218 skip_rules => 1, # no rules before opts 219 attributes => $dsn_attribs, 220 parse_attributes => $parse_dsn_attribs, 221 ); 222 my @dsn_opts = map { 223 my $opts = { 224 key => $_->{spec}->{key}, 225 dsn => $_->{spec}->{dsn}, 226 copy => $_->{spec}->{copy}, 227 desc => $_->{desc}, 228 }; 229 $opts; 230 } $dsn_o->_pod_to_specs($file); 231 $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts); 232 } 233 234 if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) { 235 $self->{version} = $1; 236 PTDEBUG && _d($self->{version}); 237 } 238 239 return; 240} 241 242sub DSNParser { 243 my ( $self ) = @_; 244 return $self->{DSNParser}; 245}; 246 247sub get_defaults_files { 248 my ( $self ) = @_; 249 return @{$self->{default_files}}; 250} 251 252sub _pod_to_specs { 253 my ( $self, $file ) = @_; 254 $file ||= $self->{file} || __FILE__; 255 open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR"; 256 257 my @specs = (); 258 my @rules = (); 259 my $para; 260 261 local $INPUT_RECORD_SEPARATOR = ''; 262 while ( $para = <$fh> ) { 263 next unless $para =~ m/^=head1 $self->{head1}/; 264 last; 265 } 266 267 while ( $para = <$fh> ) { 268 last if $para =~ m/^=over/; 269 next if $self->{skip_rules}; 270 chomp $para; 271 $para =~ s/\s+/ /g; 272 $para =~ s/$POD_link_re/$1/go; 273 PTDEBUG && _d('Option rule:', $para); 274 push @rules, $para; 275 } 276 277 die "POD has no $self->{head1} section" unless $para; 278 279 do { 280 if ( my ($option) = $para =~ m/^=item $self->{item}/ ) { 281 chomp $para; 282 PTDEBUG && _d($para); 283 my %attribs; 284 285 $para = <$fh>; # read next paragraph, possibly attributes 286 287 if ( $para =~ m/: / ) { # attributes 288 $para =~ s/\s+\Z//g; 289 %attribs = map { 290 my ( $attrib, $val) = split(/: /, $_); 291 die "Unrecognized attribute for --$option: $attrib" 292 unless $self->{attributes}->{$attrib}; 293 ($attrib, $val); 294 } split(/; /, $para); 295 if ( $attribs{'short form'} ) { 296 $attribs{'short form'} =~ s/-//; 297 } 298 $para = <$fh>; # read next paragraph, probably short help desc 299 } 300 else { 301 PTDEBUG && _d('Option has no attributes'); 302 } 303 304 $para =~ s/\s+\Z//g; 305 $para =~ s/\s+/ /g; 306 $para =~ s/$POD_link_re/$1/go; 307 308 $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s; 309 PTDEBUG && _d('Short help:', $para); 310 311 die "No description after option spec $option" if $para =~ m/^=item/; 312 313 if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) { 314 $option = $base_option; 315 $attribs{'negatable'} = 1; 316 } 317 318 push @specs, { 319 spec => $self->{parse_attributes}->($self, $option, \%attribs), 320 desc => $para 321 . (defined $attribs{default} ? " (default $attribs{default})" : ''), 322 group => ($attribs{'group'} ? $attribs{'group'} : 'default'), 323 attributes => \%attribs 324 }; 325 } 326 while ( $para = <$fh> ) { 327 last unless $para; 328 if ( $para =~ m/^=head1/ ) { 329 $para = undef; # Can't 'last' out of a do {} block. 330 last; 331 } 332 last if $para =~ m/^=item /; 333 } 334 } while ( $para ); 335 336 die "No valid specs in $self->{head1}" unless @specs; 337 338 close $fh; 339 return @specs, @rules; 340} 341 342sub _parse_specs { 343 my ( $self, @specs ) = @_; 344 my %disables; # special rule that requires deferred checking 345 346 foreach my $opt ( @specs ) { 347 if ( ref $opt ) { # It's an option spec, not a rule. 348 PTDEBUG && _d('Parsing opt spec:', 349 map { ($_, '=>', $opt->{$_}) } keys %$opt); 350 351 my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/; 352 if ( !$long ) { 353 die "Cannot parse long option from spec $opt->{spec}"; 354 } 355 $opt->{long} = $long; 356 357 die "Duplicate long option --$long" if exists $self->{opts}->{$long}; 358 $self->{opts}->{$long} = $opt; 359 360 if ( length $long == 1 ) { 361 PTDEBUG && _d('Long opt', $long, 'looks like short opt'); 362 $self->{short_opts}->{$long} = $long; 363 } 364 365 if ( $short ) { 366 die "Duplicate short option -$short" 367 if exists $self->{short_opts}->{$short}; 368 $self->{short_opts}->{$short} = $long; 369 $opt->{short} = $short; 370 } 371 else { 372 $opt->{short} = undef; 373 } 374 375 $opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0; 376 $opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0; 377 $opt->{is_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0; 378 $opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0; 379 380 $opt->{group} ||= 'default'; 381 $self->{groups}->{ $opt->{group} }->{$long} = 1; 382 383 $opt->{value} = undef; 384 $opt->{got} = 0; 385 386 my ( $type ) = $opt->{spec} =~ m/=(.)/; 387 $opt->{type} = $type; 388 PTDEBUG && _d($long, 'type:', $type); 389 390 391 $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ ); 392 393 if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) { 394 $self->{defaults}->{$long} = defined $def ? $def : 1; 395 PTDEBUG && _d($long, 'default:', $def); 396 } 397 398 if ( $long eq 'config' ) { 399 $self->{defaults}->{$long} = join(',', $self->get_defaults_files()); 400 } 401 402 if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) { 403 $disables{$long} = $dis; 404 PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis); 405 } 406 407 $self->{opts}->{$long} = $opt; 408 } 409 else { # It's an option rule, not a spec. 410 PTDEBUG && _d('Parsing rule:', $opt); 411 push @{$self->{rules}}, $opt; 412 my @participants = $self->_get_participants($opt); 413 my $rule_ok = 0; 414 415 if ( $opt =~ m/mutually exclusive|one and only one/ ) { 416 $rule_ok = 1; 417 push @{$self->{mutex}}, \@participants; 418 PTDEBUG && _d(@participants, 'are mutually exclusive'); 419 } 420 if ( $opt =~ m/at least one|one and only one/ ) { 421 $rule_ok = 1; 422 push @{$self->{atleast1}}, \@participants; 423 PTDEBUG && _d(@participants, 'require at least one'); 424 } 425 if ( $opt =~ m/default to/ ) { 426 $rule_ok = 1; 427 $self->{defaults_to}->{$participants[0]} = $participants[1]; 428 PTDEBUG && _d($participants[0], 'defaults to', $participants[1]); 429 } 430 if ( $opt =~ m/restricted to option groups/ ) { 431 $rule_ok = 1; 432 my ($groups) = $opt =~ m/groups ([\w\s\,]+)/; 433 my @groups = split(',', $groups); 434 %{$self->{allowed_groups}->{$participants[0]}} = map { 435 s/\s+//; 436 $_ => 1; 437 } @groups; 438 } 439 if( $opt =~ m/accepts additional command-line arguments/ ) { 440 $rule_ok = 1; 441 $self->{strict} = 0; 442 PTDEBUG && _d("Strict mode disabled by rule"); 443 } 444 445 die "Unrecognized option rule: $opt" unless $rule_ok; 446 } 447 } 448 449 foreach my $long ( keys %disables ) { 450 my @participants = $self->_get_participants($disables{$long}); 451 $self->{disables}->{$long} = \@participants; 452 PTDEBUG && _d('Option', $long, 'disables', @participants); 453 } 454 455 return; 456} 457 458sub _get_participants { 459 my ( $self, $str ) = @_; 460 my @participants; 461 foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) { 462 die "Option --$long does not exist while processing rule $str" 463 unless exists $self->{opts}->{$long}; 464 push @participants, $long; 465 } 466 PTDEBUG && _d('Participants for', $str, ':', @participants); 467 return @participants; 468} 469 470sub opts { 471 my ( $self ) = @_; 472 my %opts = %{$self->{opts}}; 473 return %opts; 474} 475 476sub short_opts { 477 my ( $self ) = @_; 478 my %short_opts = %{$self->{short_opts}}; 479 return %short_opts; 480} 481 482sub set_defaults { 483 my ( $self, %defaults ) = @_; 484 $self->{defaults} = {}; 485 foreach my $long ( keys %defaults ) { 486 die "Cannot set default for nonexistent option $long" 487 unless exists $self->{opts}->{$long}; 488 $self->{defaults}->{$long} = $defaults{$long}; 489 PTDEBUG && _d('Default val for', $long, ':', $defaults{$long}); 490 } 491 return; 492} 493 494sub get_defaults { 495 my ( $self ) = @_; 496 return $self->{defaults}; 497} 498 499sub get_groups { 500 my ( $self ) = @_; 501 return $self->{groups}; 502} 503 504sub _set_option { 505 my ( $self, $opt, $val ) = @_; 506 my $long = exists $self->{opts}->{$opt} ? $opt 507 : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt} 508 : die "Getopt::Long gave a nonexistent option: $opt"; 509 $opt = $self->{opts}->{$long}; 510 if ( $opt->{is_cumulative} ) { 511 $opt->{value}++; 512 } 513 elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) { 514 my $next_opt = $1; 515 if ( exists $self->{opts}->{$next_opt} 516 || exists $self->{short_opts}->{$next_opt} ) { 517 $self->save_error("--$long requires a string value"); 518 return; 519 } 520 else { 521 if ($opt->{is_repeatable}) { 522 push @{$opt->{value}} , $val; 523 } 524 else { 525 $opt->{value} = $val; 526 } 527 } 528 } 529 else { 530 if ($opt->{is_repeatable}) { 531 push @{$opt->{value}} , $val; 532 } 533 else { 534 $opt->{value} = $val; 535 } 536 } 537 $opt->{got} = 1; 538 PTDEBUG && _d('Got option', $long, '=', $val); 539} 540 541sub get_opts { 542 my ( $self ) = @_; 543 544 foreach my $long ( keys %{$self->{opts}} ) { 545 $self->{opts}->{$long}->{got} = 0; 546 $self->{opts}->{$long}->{value} 547 = exists $self->{defaults}->{$long} ? $self->{defaults}->{$long} 548 : $self->{opts}->{$long}->{is_cumulative} ? 0 549 : undef; 550 } 551 $self->{got_opts} = 0; 552 553 $self->{errors} = []; 554 555 if ( @ARGV && $ARGV[0] =~/^--config=/ ) { 556 $ARGV[0] = substr($ARGV[0],9); 557 $ARGV[0] =~ s/^'(.*)'$/$1/; 558 $ARGV[0] =~ s/^"(.*)"$/$1/; 559 $self->_set_option('config', shift @ARGV); 560 } 561 if ( @ARGV && $ARGV[0] eq "--config" ) { 562 shift @ARGV; 563 $self->_set_option('config', shift @ARGV); 564 } 565 if ( $self->has('config') ) { 566 my @extra_args; 567 foreach my $filename ( split(',', $self->get('config')) ) { 568 eval { 569 push @extra_args, $self->_read_config_file($filename); 570 }; 571 if ( $EVAL_ERROR ) { 572 if ( $self->got('config') ) { 573 die $EVAL_ERROR; 574 } 575 elsif ( PTDEBUG ) { 576 _d($EVAL_ERROR); 577 } 578 } 579 } 580 unshift @ARGV, @extra_args; 581 } 582 583 Getopt::Long::Configure('no_ignore_case', 'bundling'); 584 GetOptions( 585 map { $_->{spec} => sub { $self->_set_option(@_); } } 586 grep { $_->{long} ne 'config' } # --config is handled specially above. 587 values %{$self->{opts}} 588 ) or $self->save_error('Error parsing options'); 589 590 if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) { 591 if ( $self->{version} ) { 592 print $self->{version}, "\n"; 593 exit 0; 594 } 595 else { 596 print "Error parsing version. See the VERSION section of the tool's documentation.\n"; 597 exit 1; 598 } 599 } 600 601 if ( @ARGV && $self->{strict} ) { 602 $self->save_error("Unrecognized command-line options @ARGV"); 603 } 604 605 foreach my $mutex ( @{$self->{mutex}} ) { 606 my @set = grep { $self->{opts}->{$_}->{got} } @$mutex; 607 if ( @set > 1 ) { 608 my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } 609 @{$mutex}[ 0 .. scalar(@$mutex) - 2] ) 610 . ' and --'.$self->{opts}->{$mutex->[-1]}->{long} 611 . ' are mutually exclusive.'; 612 $self->save_error($err); 613 } 614 } 615 616 foreach my $required ( @{$self->{atleast1}} ) { 617 my @set = grep { $self->{opts}->{$_}->{got} } @$required; 618 if ( @set == 0 ) { 619 my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } 620 @{$required}[ 0 .. scalar(@$required) - 2] ) 621 .' or --'.$self->{opts}->{$required->[-1]}->{long}; 622 $self->save_error("Specify at least one of $err"); 623 } 624 } 625 626 $self->_check_opts( keys %{$self->{opts}} ); 627 $self->{got_opts} = 1; 628 return; 629} 630 631sub _check_opts { 632 my ( $self, @long ) = @_; 633 my $long_last = scalar @long; 634 while ( @long ) { 635 foreach my $i ( 0..$#long ) { 636 my $long = $long[$i]; 637 next unless $long; 638 my $opt = $self->{opts}->{$long}; 639 if ( $opt->{got} ) { 640 if ( exists $self->{disables}->{$long} ) { 641 my @disable_opts = @{$self->{disables}->{$long}}; 642 map { $self->{opts}->{$_}->{value} = undef; } @disable_opts; 643 PTDEBUG && _d('Unset options', @disable_opts, 644 'because', $long,'disables them'); 645 } 646 647 if ( exists $self->{allowed_groups}->{$long} ) { 648 649 my @restricted_groups = grep { 650 !exists $self->{allowed_groups}->{$long}->{$_} 651 } keys %{$self->{groups}}; 652 653 my @restricted_opts; 654 foreach my $restricted_group ( @restricted_groups ) { 655 RESTRICTED_OPT: 656 foreach my $restricted_opt ( 657 keys %{$self->{groups}->{$restricted_group}} ) 658 { 659 next RESTRICTED_OPT if $restricted_opt eq $long; 660 push @restricted_opts, $restricted_opt 661 if $self->{opts}->{$restricted_opt}->{got}; 662 } 663 } 664 665 if ( @restricted_opts ) { 666 my $err; 667 if ( @restricted_opts == 1 ) { 668 $err = "--$restricted_opts[0]"; 669 } 670 else { 671 $err = join(', ', 672 map { "--$self->{opts}->{$_}->{long}" } 673 grep { $_ } 674 @restricted_opts[0..scalar(@restricted_opts) - 2] 675 ) 676 . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long}; 677 } 678 $self->save_error("--$long is not allowed with $err"); 679 } 680 } 681 682 } 683 elsif ( $opt->{is_required} ) { 684 $self->save_error("Required option --$long must be specified"); 685 } 686 687 $self->_validate_type($opt); 688 if ( $opt->{parsed} ) { 689 delete $long[$i]; 690 } 691 else { 692 PTDEBUG && _d('Temporarily failed to parse', $long); 693 } 694 } 695 696 die "Failed to parse options, possibly due to circular dependencies" 697 if @long == $long_last; 698 $long_last = @long; 699 } 700 701 return; 702} 703 704sub _validate_type { 705 my ( $self, $opt ) = @_; 706 return unless $opt; 707 708 if ( !$opt->{type} ) { 709 $opt->{parsed} = 1; 710 return; 711 } 712 713 my $val = $opt->{value}; 714 715 if ( $val && $opt->{type} eq 'm' ) { # type time 716 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value'); 717 my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/; 718 if ( !$suffix ) { 719 my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/; 720 $suffix = $s || 's'; 721 PTDEBUG && _d('No suffix given; using', $suffix, 'for', 722 $opt->{long}, '(value:', $val, ')'); 723 } 724 if ( $suffix =~ m/[smhd]/ ) { 725 $val = $suffix eq 's' ? $num # Seconds 726 : $suffix eq 'm' ? $num * 60 # Minutes 727 : $suffix eq 'h' ? $num * 3600 # Hours 728 : $num * 86400; # Days 729 $opt->{value} = ($prefix || '') . $val; 730 PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val); 731 } 732 else { 733 $self->save_error("Invalid time suffix for --$opt->{long}"); 734 } 735 } 736 elsif ( $val && $opt->{type} eq 'd' ) { # type DSN 737 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN'); 738 my $prev = {}; 739 my $from_key = $self->{defaults_to}->{ $opt->{long} }; 740 if ( $from_key ) { 741 PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN'); 742 if ( $self->{opts}->{$from_key}->{parsed} ) { 743 $prev = $self->{opts}->{$from_key}->{value}; 744 } 745 else { 746 PTDEBUG && _d('Cannot parse', $opt->{long}, 'until', 747 $from_key, 'parsed'); 748 return; 749 } 750 } 751 my $defaults = $self->{DSNParser}->parse_options($self); 752 if (!$opt->{attributes}->{repeatable}) { 753 $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults); 754 } else { 755 my $values = []; 756 for my $dsn_string (@$val) { 757 push @$values, $self->{DSNParser}->parse($dsn_string, $prev, $defaults); 758 } 759 $opt->{value} = $values; 760 } 761 } 762 elsif ( $val && $opt->{type} eq 'z' ) { # type size 763 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value'); 764 $self->_parse_size($opt, $val); 765 } 766 elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) { 767 $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) }; 768 } 769 elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) { 770 $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ]; 771 } 772 else { 773 PTDEBUG && _d('Nothing to validate for option', 774 $opt->{long}, 'type', $opt->{type}, 'value', $val); 775 } 776 777 $opt->{parsed} = 1; 778 return; 779} 780 781sub get { 782 my ( $self, $opt ) = @_; 783 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 784 die "Option $opt does not exist" 785 unless $long && exists $self->{opts}->{$long}; 786 return $self->{opts}->{$long}->{value}; 787} 788 789sub got { 790 my ( $self, $opt ) = @_; 791 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 792 die "Option $opt does not exist" 793 unless $long && exists $self->{opts}->{$long}; 794 return $self->{opts}->{$long}->{got}; 795} 796 797sub has { 798 my ( $self, $opt ) = @_; 799 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 800 return defined $long ? exists $self->{opts}->{$long} : 0; 801} 802 803sub set { 804 my ( $self, $opt, $val ) = @_; 805 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 806 die "Option $opt does not exist" 807 unless $long && exists $self->{opts}->{$long}; 808 $self->{opts}->{$long}->{value} = $val; 809 return; 810} 811 812sub save_error { 813 my ( $self, $error ) = @_; 814 push @{$self->{errors}}, $error; 815 return; 816} 817 818sub errors { 819 my ( $self ) = @_; 820 return $self->{errors}; 821} 822 823sub usage { 824 my ( $self ) = @_; 825 warn "No usage string is set" unless $self->{usage}; # XXX 826 return "Usage: " . ($self->{usage} || '') . "\n"; 827} 828 829sub descr { 830 my ( $self ) = @_; 831 warn "No description string is set" unless $self->{description}; # XXX 832 my $descr = ($self->{description} || $self->{program_name} || '') 833 . " For more details, please use the --help option, " 834 . "or try 'perldoc $PROGRAM_NAME' " 835 . "for complete documentation."; 836 $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g) 837 unless $ENV{DONT_BREAK_LINES}; 838 $descr =~ s/ +$//mg; 839 return $descr; 840} 841 842sub usage_or_errors { 843 my ( $self, $file, $return ) = @_; 844 $file ||= $self->{file} || __FILE__; 845 846 if ( !$self->{description} || !$self->{usage} ) { 847 PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file); 848 my %synop = $self->_parse_synopsis($file); 849 $self->{description} ||= $synop{description}; 850 $self->{usage} ||= $synop{usage}; 851 PTDEBUG && _d("Description:", $self->{description}, 852 "\nUsage:", $self->{usage}); 853 } 854 855 if ( $self->{opts}->{help}->{got} ) { 856 print $self->print_usage() or die "Cannot print usage: $OS_ERROR"; 857 exit 0 unless $return; 858 } 859 elsif ( scalar @{$self->{errors}} ) { 860 print $self->print_errors() or die "Cannot print errors: $OS_ERROR"; 861 exit 1 unless $return; 862 } 863 864 return; 865} 866 867sub print_errors { 868 my ( $self ) = @_; 869 my $usage = $self->usage() . "\n"; 870 if ( (my @errors = @{$self->{errors}}) ) { 871 $usage .= join("\n * ", 'Errors in command-line arguments:', @errors) 872 . "\n"; 873 } 874 return $usage . "\n" . $self->descr(); 875} 876 877sub print_usage { 878 my ( $self ) = @_; 879 die "Run get_opts() before print_usage()" unless $self->{got_opts}; 880 my @opts = values %{$self->{opts}}; 881 882 my $maxl = max( 883 map { 884 length($_->{long}) # option long name 885 + ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable 886 + ($_->{type} ? 2 : 0) # "=x" where x is the opt type 887 } 888 @opts); 889 890 my $maxs = max(0, 891 map { 892 length($_) 893 + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0) 894 + ($self->{opts}->{$_}->{type} ? 2 : 0) 895 } 896 values %{$self->{short_opts}}); 897 898 my $lcol = max($maxl, ($maxs + 3)); 899 my $rcol = 80 - $lcol - 6; 900 my $rpad = ' ' x ( 80 - $rcol ); 901 902 $maxs = max($lcol - 3, $maxs); 903 904 my $usage = $self->descr() . "\n" . $self->usage(); 905 906 my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}}; 907 push @groups, 'default'; 908 909 foreach my $group ( reverse @groups ) { 910 $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n"; 911 foreach my $opt ( 912 sort { $a->{long} cmp $b->{long} } 913 grep { $_->{group} eq $group } 914 @opts ) 915 { 916 my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long}; 917 my $short = $opt->{short}; 918 my $desc = $opt->{desc}; 919 920 $long .= $opt->{type} ? "=$opt->{type}" : ""; 921 922 if ( $opt->{type} && $opt->{type} eq 'm' ) { 923 my ($s) = $desc =~ m/\(suffix (.)\)/; 924 $s ||= 's'; 925 $desc =~ s/\s+\(suffix .\)//; 926 $desc .= ". Optional suffix s=seconds, m=minutes, h=hours, " 927 . "d=days; if no suffix, $s is used."; 928 } 929 $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g); 930 $desc =~ s/ +$//mg; 931 if ( $short ) { 932 $usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc); 933 } 934 else { 935 $usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc); 936 } 937 } 938 } 939 940 $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n"; 941 942 if ( (my @rules = @{$self->{rules}}) ) { 943 $usage .= "\nRules:\n\n"; 944 $usage .= join("\n", map { " $_" } @rules) . "\n"; 945 } 946 if ( $self->{DSNParser} ) { 947 $usage .= "\n" . $self->{DSNParser}->usage(); 948 } 949 $usage .= "\nOptions and values after processing arguments:\n\n"; 950 foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) { 951 my $val = $opt->{value}; 952 my $type = $opt->{type} || ''; 953 my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/; 954 $val = $bool ? ( $val ? 'TRUE' : 'FALSE' ) 955 : !defined $val ? '(No value)' 956 : $type eq 'd' ? $self->{DSNParser}->as_string($val) 957 : $type =~ m/H|h/ ? join(',', sort keys %$val) 958 : $type =~ m/A|a/ ? join(',', @$val) 959 : $val; 960 $usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val); 961 } 962 return $usage; 963} 964 965sub prompt_noecho { 966 shift @_ if ref $_[0] eq __PACKAGE__; 967 my ( $prompt ) = @_; 968 local $OUTPUT_AUTOFLUSH = 1; 969 print STDERR $prompt 970 or die "Cannot print: $OS_ERROR"; 971 my $response; 972 eval { 973 require Term::ReadKey; 974 Term::ReadKey::ReadMode('noecho'); 975 chomp($response = <STDIN>); 976 Term::ReadKey::ReadMode('normal'); 977 print "\n" 978 or die "Cannot print: $OS_ERROR"; 979 }; 980 if ( $EVAL_ERROR ) { 981 die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR"; 982 } 983 return $response; 984} 985 986sub _read_config_file { 987 my ( $self, $filename ) = @_; 988 open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n"; 989 my @args; 990 my $prefix = '--'; 991 my $parse = 1; 992 993 LINE: 994 while ( my $line = <$fh> ) { 995 chomp $line; 996 next LINE if $line =~ m/^\s*(?:\#|\;|$)/; 997 $line =~ s/\s+#.*$//g; 998 $line =~ s/^\s+|\s+$//g; 999 if ( $line eq '--' ) { 1000 $prefix = ''; 1001 $parse = 0; 1002 next LINE; 1003 } 1004 1005 if ( $parse 1006 && !$self->has('version-check') 1007 && $line =~ /version-check/ 1008 ) { 1009 next LINE; 1010 } 1011 1012 if ( $parse 1013 && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/) 1014 ) { 1015 push @args, grep { defined $_ } ("$prefix$opt", $arg); 1016 } 1017 elsif ( $line =~ m/./ ) { 1018 push @args, $line; 1019 } 1020 else { 1021 die "Syntax error in file $filename at line $INPUT_LINE_NUMBER"; 1022 } 1023 } 1024 close $fh; 1025 return @args; 1026} 1027 1028sub read_para_after { 1029 my ( $self, $file, $regex ) = @_; 1030 open my $fh, "<", $file or die "Can't open $file: $OS_ERROR"; 1031 local $INPUT_RECORD_SEPARATOR = ''; 1032 my $para; 1033 while ( $para = <$fh> ) { 1034 next unless $para =~ m/^=pod$/m; 1035 last; 1036 } 1037 while ( $para = <$fh> ) { 1038 next unless $para =~ m/$regex/; 1039 last; 1040 } 1041 $para = <$fh>; 1042 chomp($para); 1043 close $fh or die "Can't close $file: $OS_ERROR"; 1044 return $para; 1045} 1046 1047sub clone { 1048 my ( $self ) = @_; 1049 1050 my %clone = map { 1051 my $hashref = $self->{$_}; 1052 my $val_copy = {}; 1053 foreach my $key ( keys %$hashref ) { 1054 my $ref = ref $hashref->{$key}; 1055 $val_copy->{$key} = !$ref ? $hashref->{$key} 1056 : $ref eq 'HASH' ? { %{$hashref->{$key}} } 1057 : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ] 1058 : $hashref->{$key}; 1059 } 1060 $_ => $val_copy; 1061 } qw(opts short_opts defaults); 1062 1063 foreach my $scalar ( qw(got_opts) ) { 1064 $clone{$scalar} = $self->{$scalar}; 1065 } 1066 1067 return bless \%clone; 1068} 1069 1070sub _parse_size { 1071 my ( $self, $opt, $val ) = @_; 1072 1073 if ( lc($val || '') eq 'null' ) { 1074 PTDEBUG && _d('NULL size for', $opt->{long}); 1075 $opt->{value} = 'null'; 1076 return; 1077 } 1078 1079 my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824); 1080 my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/; 1081 if ( defined $num ) { 1082 if ( $factor ) { 1083 $num *= $factor_for{$factor}; 1084 PTDEBUG && _d('Setting option', $opt->{y}, 1085 'to num', $num, '* factor', $factor); 1086 } 1087 $opt->{value} = ($pre || '') . $num; 1088 } 1089 else { 1090 $self->save_error("Invalid size for --$opt->{long}: $val"); 1091 } 1092 return; 1093} 1094 1095sub _parse_attribs { 1096 my ( $self, $option, $attribs ) = @_; 1097 my $types = $self->{types}; 1098 return $option 1099 . ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' ) 1100 . ($attribs->{'negatable'} ? '!' : '' ) 1101 . ($attribs->{'cumulative'} ? '+' : '' ) 1102 . ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' ); 1103} 1104 1105sub _parse_synopsis { 1106 my ( $self, $file ) = @_; 1107 $file ||= $self->{file} || __FILE__; 1108 PTDEBUG && _d("Parsing SYNOPSIS in", $file); 1109 1110 local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs 1111 open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 1112 my $para; 1113 1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/; 1114 die "$file does not contain a SYNOPSIS section" unless $para; 1115 my @synop; 1116 for ( 1..2 ) { # 1 for the usage, 2 for the description 1117 my $para = <$fh>; 1118 push @synop, $para; 1119 } 1120 close $fh; 1121 PTDEBUG && _d("Raw SYNOPSIS text:", @synop); 1122 my ($usage, $desc) = @synop; 1123 die "The SYNOPSIS section in $file is not formatted properly" 1124 unless $usage && $desc; 1125 1126 $usage =~ s/^\s*Usage:\s+(.+)/$1/; 1127 chomp $usage; 1128 1129 $desc =~ s/\n/ /g; 1130 $desc =~ s/\s{2,}/ /g; 1131 $desc =~ s/\. ([A-Z][a-z])/. $1/g; 1132 $desc =~ s/\s+$//; 1133 1134 return ( 1135 description => $desc, 1136 usage => $usage, 1137 ); 1138}; 1139 1140sub set_vars { 1141 my ($self, $file) = @_; 1142 $file ||= $self->{file} || __FILE__; 1143 1144 my %user_vars; 1145 my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef; 1146 if ( $user_vars ) { 1147 foreach my $var_val ( @$user_vars ) { 1148 my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; 1149 die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; 1150 $user_vars{$var} = { 1151 val => $val, 1152 default => 0, 1153 }; 1154 } 1155 } 1156 1157 my %default_vars; 1158 my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/); 1159 if ( $default_vars ) { 1160 %default_vars = map { 1161 my $var_val = $_; 1162 my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; 1163 die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; 1164 $var => { 1165 val => $val, 1166 default => 1, 1167 }; 1168 } split("\n", $default_vars); 1169 } 1170 1171 my %vars = ( 1172 %default_vars, # first the tool's defaults 1173 %user_vars, # then the user's which overwrite the defaults 1174 ); 1175 PTDEBUG && _d('--set-vars:', Dumper(\%vars)); 1176 return \%vars; 1177} 1178 1179sub _d { 1180 my ($package, undef, $line) = caller 0; 1181 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 1182 map { defined $_ ? $_ : 'undef' } 1183 @_; 1184 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 1185} 1186 1187if ( PTDEBUG ) { 1188 print STDERR '# ', $^X, ' ', $], "\n"; 1189 if ( my $uname = `uname -a` ) { 1190 $uname =~ s/\s+/ /g; 1191 print STDERR "# $uname\n"; 1192 } 1193 print STDERR '# Arguments: ', 1194 join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n"; 1195} 1196 11971; 1198} 1199# ########################################################################### 1200# End OptionParser package 1201# ########################################################################### 1202 1203# ########################################################################### 1204# Quoter package 1205# This package is a copy without comments from the original. The original 1206# with comments and its test file can be found in the Bazaar repository at, 1207# lib/Quoter.pm 1208# t/lib/Quoter.t 1209# See https://launchpad.net/percona-toolkit for more information. 1210# ########################################################################### 1211{ 1212package Quoter; 1213 1214use strict; 1215use warnings FATAL => 'all'; 1216use English qw(-no_match_vars); 1217use constant PTDEBUG => $ENV{PTDEBUG} || 0; 1218 1219use Data::Dumper; 1220$Data::Dumper::Indent = 1; 1221$Data::Dumper::Sortkeys = 1; 1222$Data::Dumper::Quotekeys = 0; 1223 1224sub new { 1225 my ( $class, %args ) = @_; 1226 return bless {}, $class; 1227} 1228 1229sub quote { 1230 my ( $self, @vals ) = @_; 1231 foreach my $val ( @vals ) { 1232 $val =~ s/`/``/g; 1233 } 1234 return join('.', map { '`' . $_ . '`' } @vals); 1235} 1236 1237sub quote_val { 1238 my ( $self, $val, %args ) = @_; 1239 1240 return 'NULL' unless defined $val; # undef = NULL 1241 return "''" if $val eq ''; # blank string = '' 1242 return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data 1243 && !$args{is_char}; # unless is_char is true 1244 1245 $val =~ s/(['\\])/\\$1/g; 1246 return "'$val'"; 1247} 1248 1249sub split_unquote { 1250 my ( $self, $db_tbl, $default_db ) = @_; 1251 my ( $db, $tbl ) = split(/[.]/, $db_tbl); 1252 if ( !$tbl ) { 1253 $tbl = $db; 1254 $db = $default_db; 1255 } 1256 for ($db, $tbl) { 1257 next unless $_; 1258 s/\A`//; 1259 s/`\z//; 1260 s/``/`/g; 1261 } 1262 1263 return ($db, $tbl); 1264} 1265 1266sub literal_like { 1267 my ( $self, $like ) = @_; 1268 return unless $like; 1269 $like =~ s/([%_])/\\$1/g; 1270 return "'$like'"; 1271} 1272 1273sub join_quote { 1274 my ( $self, $default_db, $db_tbl ) = @_; 1275 return unless $db_tbl; 1276 my ($db, $tbl) = split(/[.]/, $db_tbl); 1277 if ( !$tbl ) { 1278 $tbl = $db; 1279 $db = $default_db; 1280 } 1281 $db = "`$db`" if $db && $db !~ m/^`/; 1282 $tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/; 1283 return $db ? "$db.$tbl" : $tbl; 1284} 1285 1286sub serialize_list { 1287 my ( $self, @args ) = @_; 1288 PTDEBUG && _d('Serializing', Dumper(\@args)); 1289 return unless @args; 1290 1291 my @parts; 1292 foreach my $arg ( @args ) { 1293 if ( defined $arg ) { 1294 $arg =~ s/,/\\,/g; # escape commas 1295 $arg =~ s/\\N/\\\\N/g; # escape literal \N 1296 push @parts, $arg; 1297 } 1298 else { 1299 push @parts, '\N'; 1300 } 1301 } 1302 1303 my $string = join(',', @parts); 1304 PTDEBUG && _d('Serialized: <', $string, '>'); 1305 return $string; 1306} 1307 1308sub deserialize_list { 1309 my ( $self, $string ) = @_; 1310 PTDEBUG && _d('Deserializing <', $string, '>'); 1311 die "Cannot deserialize an undefined string" unless defined $string; 1312 1313 my @parts; 1314 foreach my $arg ( split(/(?<!\\),/, $string) ) { 1315 if ( $arg eq '\N' ) { 1316 $arg = undef; 1317 } 1318 else { 1319 $arg =~ s/\\,/,/g; 1320 $arg =~ s/\\\\N/\\N/g; 1321 } 1322 push @parts, $arg; 1323 } 1324 1325 if ( !@parts ) { 1326 my $n_empty_strings = $string =~ tr/,//; 1327 $n_empty_strings++; 1328 PTDEBUG && _d($n_empty_strings, 'empty strings'); 1329 map { push @parts, '' } 1..$n_empty_strings; 1330 } 1331 elsif ( $string =~ m/(?<!\\),$/ ) { 1332 PTDEBUG && _d('Last value is an empty string'); 1333 push @parts, ''; 1334 } 1335 1336 PTDEBUG && _d('Deserialized', Dumper(\@parts)); 1337 return @parts; 1338} 1339 1340sub _d { 1341 my ($package, undef, $line) = caller 0; 1342 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 1343 map { defined $_ ? $_ : 'undef' } 1344 @_; 1345 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 1346} 1347 13481; 1349} 1350# ########################################################################### 1351# End Quoter package 1352# ########################################################################### 1353 1354# ########################################################################### 1355# DSNParser package 1356# This package is a copy without comments from the original. The original 1357# with comments and its test file can be found in the Bazaar repository at, 1358# lib/DSNParser.pm 1359# t/lib/DSNParser.t 1360# See https://launchpad.net/percona-toolkit for more information. 1361# ########################################################################### 1362{ 1363package DSNParser; 1364 1365use strict; 1366use warnings FATAL => 'all'; 1367use English qw(-no_match_vars); 1368use constant PTDEBUG => $ENV{PTDEBUG} || 0; 1369 1370use Data::Dumper; 1371$Data::Dumper::Indent = 0; 1372$Data::Dumper::Quotekeys = 0; 1373 1374my $dsn_sep = qr/(?<!\\),/; 1375 1376eval { 1377 require DBI; 1378}; 1379my $have_dbi = $EVAL_ERROR ? 0 : 1; 1380 1381sub new { 1382 my ( $class, %args ) = @_; 1383 foreach my $arg ( qw(opts) ) { 1384 die "I need a $arg argument" unless $args{$arg}; 1385 } 1386 my $self = { 1387 opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD. 1388 }; 1389 foreach my $opt ( @{$args{opts}} ) { 1390 if ( !$opt->{key} || !$opt->{desc} ) { 1391 die "Invalid DSN option: ", Dumper($opt); 1392 } 1393 PTDEBUG && _d('DSN option:', 1394 join(', ', 1395 map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') } 1396 keys %$opt 1397 ) 1398 ); 1399 $self->{opts}->{$opt->{key}} = { 1400 dsn => $opt->{dsn}, 1401 desc => $opt->{desc}, 1402 copy => $opt->{copy} || 0, 1403 }; 1404 } 1405 return bless $self, $class; 1406} 1407 1408sub prop { 1409 my ( $self, $prop, $value ) = @_; 1410 if ( @_ > 2 ) { 1411 PTDEBUG && _d('Setting', $prop, 'property'); 1412 $self->{$prop} = $value; 1413 } 1414 return $self->{$prop}; 1415} 1416 1417sub parse { 1418 my ( $self, $dsn, $prev, $defaults ) = @_; 1419 if ( !$dsn ) { 1420 PTDEBUG && _d('No DSN to parse'); 1421 return; 1422 } 1423 PTDEBUG && _d('Parsing', $dsn); 1424 $prev ||= {}; 1425 $defaults ||= {}; 1426 my %given_props; 1427 my %final_props; 1428 my $opts = $self->{opts}; 1429 1430 foreach my $dsn_part ( split($dsn_sep, $dsn) ) { 1431 $dsn_part =~ s/\\,/,/g; 1432 if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) { 1433 $given_props{$prop_key} = $prop_val; 1434 } 1435 else { 1436 PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part); 1437 $given_props{h} = $dsn_part; 1438 } 1439 } 1440 1441 foreach my $key ( keys %$opts ) { 1442 PTDEBUG && _d('Finding value for', $key); 1443 $final_props{$key} = $given_props{$key}; 1444 if ( !defined $final_props{$key} 1445 && defined $prev->{$key} && $opts->{$key}->{copy} ) 1446 { 1447 $final_props{$key} = $prev->{$key}; 1448 PTDEBUG && _d('Copying value for', $key, 'from previous DSN'); 1449 } 1450 if ( !defined $final_props{$key} ) { 1451 $final_props{$key} = $defaults->{$key}; 1452 PTDEBUG && _d('Copying value for', $key, 'from defaults'); 1453 } 1454 } 1455 1456 foreach my $key ( keys %given_props ) { 1457 die "Unknown DSN option '$key' in '$dsn'. For more details, " 1458 . "please use the --help option, or try 'perldoc $PROGRAM_NAME' " 1459 . "for complete documentation." 1460 unless exists $opts->{$key}; 1461 } 1462 if ( (my $required = $self->prop('required')) ) { 1463 foreach my $key ( keys %$required ) { 1464 die "Missing required DSN option '$key' in '$dsn'. For more details, " 1465 . "please use the --help option, or try 'perldoc $PROGRAM_NAME' " 1466 . "for complete documentation." 1467 unless $final_props{$key}; 1468 } 1469 } 1470 1471 return \%final_props; 1472} 1473 1474sub parse_options { 1475 my ( $self, $o ) = @_; 1476 die 'I need an OptionParser object' unless ref $o eq 'OptionParser'; 1477 my $dsn_string 1478 = join(',', 1479 map { "$_=".$o->get($_); } 1480 grep { $o->has($_) && $o->get($_) } 1481 keys %{$self->{opts}} 1482 ); 1483 PTDEBUG && _d('DSN string made from options:', $dsn_string); 1484 return $self->parse($dsn_string); 1485} 1486 1487sub as_string { 1488 my ( $self, $dsn, $props ) = @_; 1489 return $dsn unless ref $dsn; 1490 my @keys = $props ? @$props : sort keys %$dsn; 1491 return join(',', 1492 map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) } 1493 grep { 1494 exists $self->{opts}->{$_} 1495 && exists $dsn->{$_} 1496 && defined $dsn->{$_} 1497 } @keys); 1498} 1499 1500sub usage { 1501 my ( $self ) = @_; 1502 my $usage 1503 = "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n" 1504 . " KEY COPY MEANING\n" 1505 . " === ==== =============================================\n"; 1506 my %opts = %{$self->{opts}}; 1507 foreach my $key ( sort keys %opts ) { 1508 $usage .= " $key " 1509 . ($opts{$key}->{copy} ? 'yes ' : 'no ') 1510 . ($opts{$key}->{desc} || '[No description]') 1511 . "\n"; 1512 } 1513 $usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n"; 1514 return $usage; 1515} 1516 1517sub get_cxn_params { 1518 my ( $self, $info ) = @_; 1519 my $dsn; 1520 my %opts = %{$self->{opts}}; 1521 my $driver = $self->prop('dbidriver') || ''; 1522 if ( $driver eq 'Pg' ) { 1523 $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';' 1524 . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" } 1525 grep { defined $info->{$_} } 1526 qw(h P)); 1527 } 1528 else { 1529 $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';' 1530 . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" } 1531 grep { defined $info->{$_} } 1532 qw(F h P S A)) 1533 . ';mysql_read_default_group=client' 1534 . ($info->{L} ? ';mysql_local_infile=1' : ''); 1535 } 1536 PTDEBUG && _d($dsn); 1537 return ($dsn, $info->{u}, $info->{p}); 1538} 1539 1540sub fill_in_dsn { 1541 my ( $self, $dbh, $dsn ) = @_; 1542 my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name'); 1543 my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()'); 1544 $user =~ s/@.*//; 1545 $dsn->{h} ||= $vars->{hostname}->{Value}; 1546 $dsn->{S} ||= $vars->{'socket'}->{Value}; 1547 $dsn->{P} ||= $vars->{port}->{Value}; 1548 $dsn->{u} ||= $user; 1549 $dsn->{D} ||= $db; 1550} 1551 1552sub get_dbh { 1553 my ( $self, $cxn_string, $user, $pass, $opts ) = @_; 1554 $opts ||= {}; 1555 my $defaults = { 1556 AutoCommit => 0, 1557 RaiseError => 1, 1558 PrintError => 0, 1559 ShowErrorStatement => 1, 1560 mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0), 1561 }; 1562 @{$defaults}{ keys %$opts } = values %$opts; 1563 if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension 1564 $defaults->{mysql_local_infile} = 1; 1565 } 1566 1567 if ( $opts->{mysql_use_result} ) { 1568 $defaults->{mysql_use_result} = 1; 1569 } 1570 1571 if ( !$have_dbi ) { 1572 die "Cannot connect to MySQL because the Perl DBI module is not " 1573 . "installed or not found. Run 'perl -MDBI' to see the directories " 1574 . "that Perl searches for DBI. If DBI is not installed, try:\n" 1575 . " Debian/Ubuntu apt-get install libdbi-perl\n" 1576 . " RHEL/CentOS yum install perl-DBI\n" 1577 . " OpenSolaris pkg install pkg:/SUNWpmdbi\n"; 1578 1579 } 1580 1581 my $dbh; 1582 my $tries = 2; 1583 while ( !$dbh && $tries-- ) { 1584 PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, 1585 join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults )); 1586 1587 $dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) }; 1588 1589 if ( !$dbh && $EVAL_ERROR ) { 1590 if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) { 1591 die "Cannot connect to MySQL because the Perl DBD::mysql module is " 1592 . "not installed or not found. Run 'perl -MDBD::mysql' to see " 1593 . "the directories that Perl searches for DBD::mysql. If " 1594 . "DBD::mysql is not installed, try:\n" 1595 . " Debian/Ubuntu apt-get install libdbd-mysql-perl\n" 1596 . " RHEL/CentOS yum install perl-DBD-MySQL\n" 1597 . " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n"; 1598 } 1599 elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) { 1600 PTDEBUG && _d('Going to try again without utf8 support'); 1601 delete $defaults->{mysql_enable_utf8}; 1602 } 1603 if ( !$tries ) { 1604 die $EVAL_ERROR; 1605 } 1606 } 1607 } 1608 1609 if ( $cxn_string =~ m/mysql/i ) { 1610 my $sql; 1611 1612 if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) { 1613 $sql = qq{/*!40101 SET NAMES "$charset"*/}; 1614 PTDEBUG && _d($dbh, $sql); 1615 eval { $dbh->do($sql) }; 1616 if ( $EVAL_ERROR ) { 1617 die "Error setting NAMES to $charset: $EVAL_ERROR"; 1618 } 1619 PTDEBUG && _d('Enabling charset for STDOUT'); 1620 if ( $charset eq 'utf8' ) { 1621 binmode(STDOUT, ':utf8') 1622 or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR"; 1623 } 1624 else { 1625 binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR"; 1626 } 1627 } 1628 1629 if ( my $vars = $self->prop('set-vars') ) { 1630 $self->set_vars($dbh, $vars); 1631 } 1632 1633 $sql = 'SELECT @@SQL_MODE'; 1634 PTDEBUG && _d($dbh, $sql); 1635 my ($sql_mode) = eval { $dbh->selectrow_array($sql) }; 1636 if ( $EVAL_ERROR ) { 1637 die "Error getting the current SQL_MODE: $EVAL_ERROR"; 1638 } 1639 1640 $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1' 1641 . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO' 1642 . ($sql_mode ? ",$sql_mode" : '') 1643 . '\'*/'; 1644 PTDEBUG && _d($dbh, $sql); 1645 eval { $dbh->do($sql) }; 1646 if ( $EVAL_ERROR ) { 1647 die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE" 1648 . ($sql_mode ? " and $sql_mode" : '') 1649 . ": $EVAL_ERROR"; 1650 } 1651 } 1652 my ($mysql_version) = eval { $dbh->selectrow_array('SELECT VERSION()') }; 1653 if ($EVAL_ERROR) { 1654 die "Cannot get MySQL version: $EVAL_ERROR"; 1655 } 1656 1657 my (undef, $character_set_server) = eval { $dbh->selectrow_array("SHOW VARIABLES LIKE 'character_set_server'") }; 1658 if ($EVAL_ERROR) { 1659 die "Cannot get MySQL var character_set_server: $EVAL_ERROR"; 1660 } 1661 1662 if ($mysql_version =~ m/^(\d+)\.(\d)\.(\d+).*/) { 1663 if ($1 >= 8 && $character_set_server =~ m/^utf8/) { 1664 $dbh->{mysql_enable_utf8} = 1; 1665 my $msg = "MySQL version $mysql_version >= 8 and character_set_server = $character_set_server\n". 1666 "Setting: SET NAMES $character_set_server"; 1667 PTDEBUG && _d($msg); 1668 eval { $dbh->do("SET NAMES 'utf8mb4'") }; 1669 if ($EVAL_ERROR) { 1670 die "Cannot SET NAMES $character_set_server: $EVAL_ERROR"; 1671 } 1672 } 1673 } 1674 1675 PTDEBUG && _d('DBH info: ', 1676 $dbh, 1677 Dumper($dbh->selectrow_hashref( 1678 'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')), 1679 'Connection info:', $dbh->{mysql_hostinfo}, 1680 'Character set info:', Dumper($dbh->selectall_arrayref( 1681 "SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})), 1682 '$DBD::mysql::VERSION:', $DBD::mysql::VERSION, 1683 '$DBI::VERSION:', $DBI::VERSION, 1684 ); 1685 1686 return $dbh; 1687} 1688 1689sub get_hostname { 1690 my ( $self, $dbh ) = @_; 1691 if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) { 1692 return $host; 1693 } 1694 my ( $hostname, $one ) = $dbh->selectrow_array( 1695 'SELECT /*!50038 @@hostname, */ 1'); 1696 return $hostname; 1697} 1698 1699sub disconnect { 1700 my ( $self, $dbh ) = @_; 1701 PTDEBUG && $self->print_active_handles($dbh); 1702 $dbh->disconnect; 1703} 1704 1705sub print_active_handles { 1706 my ( $self, $thing, $level ) = @_; 1707 $level ||= 0; 1708 printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level, 1709 $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : '')) 1710 or die "Cannot print: $OS_ERROR"; 1711 foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) { 1712 $self->print_active_handles( $handle, $level + 1 ); 1713 } 1714} 1715 1716sub copy { 1717 my ( $self, $dsn_1, $dsn_2, %args ) = @_; 1718 die 'I need a dsn_1 argument' unless $dsn_1; 1719 die 'I need a dsn_2 argument' unless $dsn_2; 1720 my %new_dsn = map { 1721 my $key = $_; 1722 my $val; 1723 if ( $args{overwrite} ) { 1724 $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key}; 1725 } 1726 else { 1727 $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key}; 1728 } 1729 $key => $val; 1730 } keys %{$self->{opts}}; 1731 return \%new_dsn; 1732} 1733 1734sub set_vars { 1735 my ($self, $dbh, $vars) = @_; 1736 1737 return unless $vars; 1738 1739 foreach my $var ( sort keys %$vars ) { 1740 my $val = $vars->{$var}->{val}; 1741 1742 (my $quoted_var = $var) =~ s/_/\\_/; 1743 my ($var_exists, $current_val); 1744 eval { 1745 ($var_exists, $current_val) = $dbh->selectrow_array( 1746 "SHOW VARIABLES LIKE '$quoted_var'"); 1747 }; 1748 my $e = $EVAL_ERROR; 1749 if ( $e ) { 1750 PTDEBUG && _d($e); 1751 } 1752 1753 if ( $vars->{$var}->{default} && !$var_exists ) { 1754 PTDEBUG && _d('Not setting default var', $var, 1755 'because it does not exist'); 1756 next; 1757 } 1758 1759 if ( $current_val && $current_val eq $val ) { 1760 PTDEBUG && _d('Not setting var', $var, 'because its value', 1761 'is already', $val); 1762 next; 1763 } 1764 1765 my $sql = "SET SESSION $var=$val"; 1766 PTDEBUG && _d($dbh, $sql); 1767 eval { $dbh->do($sql) }; 1768 if ( my $set_error = $EVAL_ERROR ) { 1769 chomp($set_error); 1770 $set_error =~ s/ at \S+ line \d+//; 1771 my $msg = "Error setting $var: $set_error"; 1772 if ( $current_val ) { 1773 $msg .= " The current value for $var is $current_val. " 1774 . "If the variable is read only (not dynamic), specify " 1775 . "--set-vars $var=$current_val to avoid this warning, " 1776 . "else manually set the variable and restart MySQL."; 1777 } 1778 warn $msg . "\n\n"; 1779 } 1780 } 1781 1782 return; 1783} 1784 1785sub _d { 1786 my ($package, undef, $line) = caller 0; 1787 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 1788 map { defined $_ ? $_ : 'undef' } 1789 @_; 1790 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 1791} 1792 17931; 1794} 1795# ########################################################################### 1796# End DSNParser package 1797# ########################################################################### 1798 1799# ########################################################################### 1800# Cxn package 1801# This package is a copy without comments from the original. The original 1802# with comments and its test file can be found in the Bazaar repository at, 1803# lib/Cxn.pm 1804# t/lib/Cxn.t 1805# See https://launchpad.net/percona-toolkit for more information. 1806# ########################################################################### 1807{ 1808package Cxn; 1809 1810use strict; 1811use warnings FATAL => 'all'; 1812use English qw(-no_match_vars); 1813use Scalar::Util qw(blessed); 1814use constant { 1815 PTDEBUG => $ENV{PTDEBUG} || 0, 1816 PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0, 1817}; 1818 1819sub new { 1820 my ( $class, %args ) = @_; 1821 my @required_args = qw(DSNParser OptionParser); 1822 foreach my $arg ( @required_args ) { 1823 die "I need a $arg argument" unless $args{$arg}; 1824 }; 1825 my ($dp, $o) = @args{@required_args}; 1826 1827 my $dsn_defaults = $dp->parse_options($o); 1828 my $prev_dsn = $args{prev_dsn}; 1829 my $dsn = $args{dsn}; 1830 if ( !$dsn ) { 1831 $args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost'); 1832 1833 $dsn = $dp->parse( 1834 $args{dsn_string}, $prev_dsn, $dsn_defaults); 1835 } 1836 elsif ( $prev_dsn ) { 1837 $dsn = $dp->copy($prev_dsn, $dsn); 1838 } 1839 1840 my $dsn_name = $dp->as_string($dsn, [qw(h P S)]) 1841 || $dp->as_string($dsn, [qw(F)]) 1842 || ''; 1843 1844 my $self = { 1845 dsn => $dsn, 1846 dbh => $args{dbh}, 1847 dsn_name => $dsn_name, 1848 hostname => '', 1849 set => $args{set}, 1850 NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1, 1851 dbh_set => 0, 1852 ask_pass => $o->get('ask-pass'), 1853 DSNParser => $dp, 1854 is_cluster_node => undef, 1855 parent => $args{parent}, 1856 }; 1857 1858 return bless $self, $class; 1859} 1860 1861sub connect { 1862 my ( $self, %opts ) = @_; 1863 my $dsn = $opts{dsn} || $self->{dsn}; 1864 my $dp = $self->{DSNParser}; 1865 1866 my $dbh = $self->{dbh}; 1867 if ( !$dbh || !$dbh->ping() ) { 1868 if ( $self->{ask_pass} && !$self->{asked_for_pass} && !defined $dsn->{p} ) { 1869 $dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: "); 1870 $self->{asked_for_pass} = 1; 1871 } 1872 $dbh = $dp->get_dbh( 1873 $dp->get_cxn_params($dsn), 1874 { 1875 AutoCommit => 1, 1876 %opts, 1877 }, 1878 ); 1879 } 1880 1881 $dbh = $self->set_dbh($dbh); 1882 if ( $opts{dsn} ) { 1883 $self->{dsn} = $dsn; 1884 $self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)]) 1885 || $dp->as_string($dsn, [qw(F)]) 1886 || ''; 1887 1888 } 1889 PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name}); 1890 return $dbh; 1891} 1892 1893sub set_dbh { 1894 my ($self, $dbh) = @_; 1895 1896 if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) { 1897 PTDEBUG && _d($dbh, 'Already set dbh'); 1898 return $dbh; 1899 } 1900 1901 PTDEBUG && _d($dbh, 'Setting dbh'); 1902 1903 $dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc}; 1904 1905 my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/'; 1906 PTDEBUG && _d($dbh, $sql); 1907 my ($server_id, $hostname) = $dbh->selectrow_array($sql); 1908 PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id); 1909 if ( $hostname ) { 1910 $self->{hostname} = $hostname; 1911 } 1912 1913 if ( $self->{parent} ) { 1914 PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent'); 1915 $dbh->{InactiveDestroy} = 1; 1916 } 1917 1918 if ( my $set = $self->{set}) { 1919 $set->($dbh); 1920 } 1921 1922 $self->{dbh} = $dbh; 1923 $self->{dbh_set} = 1; 1924 return $dbh; 1925} 1926 1927sub lost_connection { 1928 my ($self, $e) = @_; 1929 return 0 unless $e; 1930 return $e =~ m/MySQL server has gone away/ 1931 || $e =~ m/Lost connection to MySQL server/ 1932 || $e =~ m/Server shutdown in progress/; 1933} 1934 1935sub dbh { 1936 my ($self) = @_; 1937 return $self->{dbh}; 1938} 1939 1940sub dsn { 1941 my ($self) = @_; 1942 return $self->{dsn}; 1943} 1944 1945sub name { 1946 my ($self) = @_; 1947 return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES; 1948 return $self->{hostname} || $self->{dsn_name} || 'unknown host'; 1949} 1950 1951sub description { 1952 my ($self) = @_; 1953 return sprintf("%s -> %s:%s", $self->name(), $self->{dsn}->{h}, $self->{dsn}->{P} || 'socket'); 1954} 1955 1956sub get_id { 1957 my ($self, $cxn) = @_; 1958 1959 $cxn ||= $self; 1960 1961 my $unique_id; 1962 if ($cxn->is_cluster_node()) { # for cluster we concatenate various variables to maximize id 'uniqueness' across versions 1963 my $sql = q{SHOW STATUS LIKE 'wsrep\_local\_index'}; 1964 my (undef, $wsrep_local_index) = $cxn->dbh->selectrow_array($sql); 1965 PTDEBUG && _d("Got cluster wsrep_local_index: ",$wsrep_local_index); 1966 $unique_id = $wsrep_local_index."|"; 1967 foreach my $val ('server\_id', 'wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') { 1968 my $sql = "SHOW VARIABLES LIKE '$val'"; 1969 PTDEBUG && _d($cxn->name, $sql); 1970 my (undef, $val) = $cxn->dbh->selectrow_array($sql); 1971 $unique_id .= "|$val"; 1972 } 1973 } else { 1974 my $sql = 'SELECT @@SERVER_ID'; 1975 PTDEBUG && _d($sql); 1976 $unique_id = $cxn->dbh->selectrow_array($sql); 1977 } 1978 PTDEBUG && _d("Generated unique id for cluster:", $unique_id); 1979 return $unique_id; 1980} 1981 1982 1983sub is_cluster_node { 1984 my ($self, $cxn) = @_; 1985 1986 $cxn ||= $self; 1987 1988 my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'"; 1989 1990 my $dbh; 1991 if ($cxn->isa('DBI::db')) { 1992 $dbh = $cxn; 1993 PTDEBUG && _d($sql); #don't invoke name() if it's not a Cxn! 1994 } 1995 else { 1996 $dbh = $cxn->dbh(); 1997 PTDEBUG && _d($cxn->name, $sql); 1998 } 1999 2000 my $row = $dbh->selectrow_arrayref($sql); 2001 return $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1') ? 1 : 0; 2002 2003} 2004 2005sub remove_duplicate_cxns { 2006 my ($self, %args) = @_; 2007 my @cxns = @{$args{cxns}}; 2008 my $seen_ids = $args{seen_ids} || {}; 2009 PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns)); 2010 my @trimmed_cxns; 2011 2012 for my $cxn ( @cxns ) { 2013 2014 my $id = $cxn->get_id(); 2015 PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id); 2016 2017 if ( ! $seen_ids->{$id}++ ) { 2018 push @trimmed_cxns, $cxn 2019 } 2020 else { 2021 PTDEBUG && _d("Removing ", $cxn->name, 2022 ", ID ", $id, ", because we've already seen it"); 2023 } 2024 } 2025 2026 return \@trimmed_cxns; 2027} 2028 2029sub DESTROY { 2030 my ($self) = @_; 2031 2032 PTDEBUG && _d('Destroying cxn'); 2033 2034 if ( $self->{parent} ) { 2035 PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent'); 2036 } 2037 elsif ( $self->{dbh} 2038 && blessed($self->{dbh}) 2039 && $self->{dbh}->can("disconnect") ) 2040 { 2041 PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname}, 2042 $self->{dsn_name}); 2043 $self->{dbh}->disconnect(); 2044 } 2045 2046 return; 2047} 2048 2049sub _d { 2050 my ($package, undef, $line) = caller 0; 2051 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 2052 map { defined $_ ? $_ : 'undef' } 2053 @_; 2054 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 2055} 2056 20571; 2058} 2059# ########################################################################### 2060# End Cxn package 2061# ########################################################################### 2062 2063# ########################################################################### 2064# Daemon package 2065# This package is a copy without comments from the original. The original 2066# with comments and its test file can be found in the Bazaar repository at, 2067# lib/Daemon.pm 2068# t/lib/Daemon.t 2069# See https://launchpad.net/percona-toolkit for more information. 2070# ########################################################################### 2071{ 2072package Daemon; 2073 2074use strict; 2075use warnings FATAL => 'all'; 2076use English qw(-no_match_vars); 2077use constant PTDEBUG => $ENV{PTDEBUG} || 0; 2078 2079use POSIX qw(setsid); 2080 2081sub new { 2082 my ( $class, %args ) = @_; 2083 foreach my $arg ( qw(o) ) { 2084 die "I need a $arg argument" unless $args{$arg}; 2085 } 2086 my $o = $args{o}; 2087 my $self = { 2088 o => $o, 2089 log_file => $o->has('log') ? $o->get('log') : undef, 2090 PID_file => $o->has('pid') ? $o->get('pid') : undef, 2091 }; 2092 2093 check_PID_file(undef, $self->{PID_file}); 2094 2095 PTDEBUG && _d('Daemonized child will log to', $self->{log_file}); 2096 return bless $self, $class; 2097} 2098 2099sub daemonize { 2100 my ( $self ) = @_; 2101 2102 PTDEBUG && _d('About to fork and daemonize'); 2103 defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR"; 2104 if ( $pid ) { 2105 PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid); 2106 exit; 2107 } 2108 2109 PTDEBUG && _d('Daemonizing child PID', $PID); 2110 $self->{PID_owner} = $PID; 2111 $self->{child} = 1; 2112 2113 POSIX::setsid() or die "Cannot start a new session: $OS_ERROR"; 2114 chdir '/' or die "Cannot chdir to /: $OS_ERROR"; 2115 2116 $self->_make_PID_file(); 2117 2118 $OUTPUT_AUTOFLUSH = 1; 2119 2120 PTDEBUG && _d('Redirecting STDIN to /dev/null'); 2121 close STDIN; 2122 open STDIN, '/dev/null' 2123 or die "Cannot reopen STDIN to /dev/null: $OS_ERROR"; 2124 2125 if ( $self->{log_file} ) { 2126 PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file}); 2127 close STDOUT; 2128 open STDOUT, '>>', $self->{log_file} 2129 or die "Cannot open log file $self->{log_file}: $OS_ERROR"; 2130 2131 close STDERR; 2132 open STDERR, ">&STDOUT" 2133 or die "Cannot dupe STDERR to STDOUT: $OS_ERROR"; 2134 } 2135 else { 2136 if ( -t STDOUT ) { 2137 PTDEBUG && _d('No log file and STDOUT is a terminal;', 2138 'redirecting to /dev/null'); 2139 close STDOUT; 2140 open STDOUT, '>', '/dev/null' 2141 or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR"; 2142 } 2143 if ( -t STDERR ) { 2144 PTDEBUG && _d('No log file and STDERR is a terminal;', 2145 'redirecting to /dev/null'); 2146 close STDERR; 2147 open STDERR, '>', '/dev/null' 2148 or die "Cannot reopen STDERR to /dev/null: $OS_ERROR"; 2149 } 2150 } 2151 2152 return; 2153} 2154 2155sub check_PID_file { 2156 my ( $self, $file ) = @_; 2157 my $PID_file = $self ? $self->{PID_file} : $file; 2158 PTDEBUG && _d('Checking PID file', $PID_file); 2159 if ( $PID_file && -f $PID_file ) { 2160 my $pid; 2161 eval { 2162 chomp($pid = (slurp_file($PID_file) || '')); 2163 }; 2164 if ( $EVAL_ERROR ) { 2165 die "The PID file $PID_file already exists but it cannot be read: " 2166 . $EVAL_ERROR; 2167 } 2168 PTDEBUG && _d('PID file exists; it contains PID', $pid); 2169 if ( $pid ) { 2170 my $pid_is_alive = kill 0, $pid; 2171 if ( $pid_is_alive ) { 2172 die "The PID file $PID_file already exists " 2173 . " and the PID that it contains, $pid, is running"; 2174 } 2175 else { 2176 warn "Overwriting PID file $PID_file because the PID that it " 2177 . "contains, $pid, is not running"; 2178 } 2179 } 2180 else { 2181 die "The PID file $PID_file already exists but it does not " 2182 . "contain a PID"; 2183 } 2184 } 2185 else { 2186 PTDEBUG && _d('No PID file'); 2187 } 2188 return; 2189} 2190 2191sub make_PID_file { 2192 my ( $self ) = @_; 2193 if ( exists $self->{child} ) { 2194 die "Do not call Daemon::make_PID_file() for daemonized scripts"; 2195 } 2196 $self->_make_PID_file(); 2197 $self->{PID_owner} = $PID; 2198 return; 2199} 2200 2201sub _make_PID_file { 2202 my ( $self ) = @_; 2203 2204 my $PID_file = $self->{PID_file}; 2205 if ( !$PID_file ) { 2206 PTDEBUG && _d('No PID file to create'); 2207 return; 2208 } 2209 2210 $self->check_PID_file(); 2211 2212 open my $PID_FH, '>', $PID_file 2213 or die "Cannot open PID file $PID_file: $OS_ERROR"; 2214 print $PID_FH $PID 2215 or die "Cannot print to PID file $PID_file: $OS_ERROR"; 2216 close $PID_FH 2217 or die "Cannot close PID file $PID_file: $OS_ERROR"; 2218 2219 PTDEBUG && _d('Created PID file:', $self->{PID_file}); 2220 return; 2221} 2222 2223sub _remove_PID_file { 2224 my ( $self ) = @_; 2225 if ( $self->{PID_file} && -f $self->{PID_file} ) { 2226 unlink $self->{PID_file} 2227 or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR"; 2228 PTDEBUG && _d('Removed PID file'); 2229 } 2230 else { 2231 PTDEBUG && _d('No PID to remove'); 2232 } 2233 return; 2234} 2235 2236sub DESTROY { 2237 my ( $self ) = @_; 2238 2239 $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID; 2240 2241 return; 2242} 2243 2244sub slurp_file { 2245 my ($file) = @_; 2246 return unless $file; 2247 open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 2248 return do { local $/; <$fh> }; 2249} 2250 2251sub _d { 2252 my ($package, undef, $line) = caller 0; 2253 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 2254 map { defined $_ ? $_ : 'undef' } 2255 @_; 2256 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 2257} 2258 22591; 2260} 2261# ########################################################################### 2262# End Daemon package 2263# ########################################################################### 2264 2265# ########################################################################### 2266# Transformers package 2267# This package is a copy without comments from the original. The original 2268# with comments and its test file can be found in the Bazaar repository at, 2269# lib/Transformers.pm 2270# t/lib/Transformers.t 2271# See https://launchpad.net/percona-toolkit for more information. 2272# ########################################################################### 2273{ 2274package Transformers; 2275 2276use strict; 2277use warnings FATAL => 'all'; 2278use English qw(-no_match_vars); 2279use constant PTDEBUG => $ENV{PTDEBUG} || 0; 2280 2281use Time::Local qw(timegm timelocal); 2282use Digest::MD5 qw(md5_hex); 2283use B qw(); 2284 2285BEGIN { 2286 require Exporter; 2287 our @ISA = qw(Exporter); 2288 our %EXPORT_TAGS = (); 2289 our @EXPORT = (); 2290 our @EXPORT_OK = qw( 2291 micro_t 2292 percentage_of 2293 secs_to_time 2294 time_to_secs 2295 shorten 2296 ts 2297 parse_timestamp 2298 unix_timestamp 2299 any_unix_timestamp 2300 make_checksum 2301 crc32 2302 encode_json 2303 ); 2304} 2305 2306our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/; 2307our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/; 2308our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks 2309 2310sub micro_t { 2311 my ( $t, %args ) = @_; 2312 my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals 2313 my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals 2314 my $f; 2315 2316 $t = 0 if $t < 0; 2317 2318 $t = sprintf('%.17f', $t) if $t =~ /e/; 2319 2320 $t =~ s/\.(\d{1,6})\d*/\.$1/; 2321 2322 if ($t > 0 && $t <= 0.000999) { 2323 $f = ($t * 1000000) . 'us'; 2324 } 2325 elsif ($t >= 0.001000 && $t <= 0.999999) { 2326 $f = sprintf("%.${p_ms}f", $t * 1000); 2327 $f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros 2328 } 2329 elsif ($t >= 1) { 2330 $f = sprintf("%.${p_s}f", $t); 2331 $f = ($f * 1) . 's'; # * 1 to remove insignificant zeros 2332 } 2333 else { 2334 $f = 0; # $t should = 0 at this point 2335 } 2336 2337 return $f; 2338} 2339 2340sub percentage_of { 2341 my ( $is, $of, %args ) = @_; 2342 my $p = $args{p} || 0; # float precision 2343 my $fmt = $p ? "%.${p}f" : "%d"; 2344 return sprintf $fmt, ($is * 100) / ($of ||= 1); 2345} 2346 2347sub secs_to_time { 2348 my ( $secs, $fmt ) = @_; 2349 $secs ||= 0; 2350 return '00:00' unless $secs; 2351 2352 $fmt ||= $secs >= 86_400 ? 'd' 2353 : $secs >= 3_600 ? 'h' 2354 : 'm'; 2355 2356 return 2357 $fmt eq 'd' ? sprintf( 2358 "%d+%02d:%02d:%02d", 2359 int($secs / 86_400), 2360 int(($secs % 86_400) / 3_600), 2361 int(($secs % 3_600) / 60), 2362 $secs % 60) 2363 : $fmt eq 'h' ? sprintf( 2364 "%02d:%02d:%02d", 2365 int(($secs % 86_400) / 3_600), 2366 int(($secs % 3_600) / 60), 2367 $secs % 60) 2368 : sprintf( 2369 "%02d:%02d", 2370 int(($secs % 3_600) / 60), 2371 $secs % 60); 2372} 2373 2374sub time_to_secs { 2375 my ( $val, $default_suffix ) = @_; 2376 die "I need a val argument" unless defined $val; 2377 my $t = 0; 2378 my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/; 2379 $suffix = $suffix || $default_suffix || 's'; 2380 if ( $suffix =~ m/[smhd]/ ) { 2381 $t = $suffix eq 's' ? $num * 1 # Seconds 2382 : $suffix eq 'm' ? $num * 60 # Minutes 2383 : $suffix eq 'h' ? $num * 3600 # Hours 2384 : $num * 86400; # Days 2385 2386 $t *= -1 if $prefix && $prefix eq '-'; 2387 } 2388 else { 2389 die "Invalid suffix for $val: $suffix"; 2390 } 2391 return $t; 2392} 2393 2394sub shorten { 2395 my ( $num, %args ) = @_; 2396 my $p = defined $args{p} ? $args{p} : 2; # float precision 2397 my $d = defined $args{d} ? $args{d} : 1_024; # divisor 2398 my $n = 0; 2399 my @units = ('', qw(k M G T P E Z Y)); 2400 while ( $num >= $d && $n < @units - 1 ) { 2401 $num /= $d; 2402 ++$n; 2403 } 2404 return sprintf( 2405 $num =~ m/\./ || $n 2406 ? '%1$.'.$p.'f%2$s' 2407 : '%1$d', 2408 $num, $units[$n]); 2409} 2410 2411sub ts { 2412 my ( $time, $gmt ) = @_; 2413 my ( $sec, $min, $hour, $mday, $mon, $year ) 2414 = $gmt ? gmtime($time) : localtime($time); 2415 $mon += 1; 2416 $year += 1900; 2417 my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d", 2418 $year, $mon, $mday, $hour, $min, $sec); 2419 if ( my ($us) = $time =~ m/(\.\d+)$/ ) { 2420 $us = sprintf("%.6f", $us); 2421 $us =~ s/^0\././; 2422 $val .= $us; 2423 } 2424 return $val; 2425} 2426 2427sub parse_timestamp { 2428 my ( $val ) = @_; 2429 if ( my($y, $m, $d, $h, $i, $s, $f) 2430 = $val =~ m/^$mysql_ts$/ ) 2431 { 2432 return sprintf "%d-%02d-%02d %02d:%02d:" 2433 . (defined $f ? '%09.6f' : '%02d'), 2434 $y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s); 2435 } 2436 elsif ( $val =~ m/^$proper_ts$/ ) { 2437 return $val; 2438 } 2439 return $val; 2440} 2441 2442sub unix_timestamp { 2443 my ( $val, $gmt ) = @_; 2444 if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) { 2445 $val = $gmt 2446 ? timegm($s, $i, $h, $d, $m - 1, $y) 2447 : timelocal($s, $i, $h, $d, $m - 1, $y); 2448 if ( defined $us ) { 2449 $us = sprintf('%.6f', $us); 2450 $us =~ s/^0\././; 2451 $val .= $us; 2452 } 2453 } 2454 return $val; 2455} 2456 2457sub any_unix_timestamp { 2458 my ( $val, $callback ) = @_; 2459 2460 if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) { 2461 $n = $suffix eq 's' ? $n # Seconds 2462 : $suffix eq 'm' ? $n * 60 # Minutes 2463 : $suffix eq 'h' ? $n * 3600 # Hours 2464 : $suffix eq 'd' ? $n * 86400 # Days 2465 : $n; # default: Seconds 2466 PTDEBUG && _d('ts is now - N[shmd]:', $n); 2467 return time - $n; 2468 } 2469 elsif ( $val =~ m/^\d{9,}/ ) { 2470 PTDEBUG && _d('ts is already a unix timestamp'); 2471 return $val; 2472 } 2473 elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) { 2474 PTDEBUG && _d('ts is MySQL slow log timestamp'); 2475 $val .= ' 00:00:00' unless $hms; 2476 return unix_timestamp(parse_timestamp($val)); 2477 } 2478 elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) { 2479 PTDEBUG && _d('ts is properly formatted timestamp'); 2480 $val .= ' 00:00:00' unless $hms; 2481 return unix_timestamp($val); 2482 } 2483 else { 2484 PTDEBUG && _d('ts is MySQL expression'); 2485 return $callback->($val) if $callback && ref $callback eq 'CODE'; 2486 } 2487 2488 PTDEBUG && _d('Unknown ts type:', $val); 2489 return; 2490} 2491 2492sub make_checksum { 2493 my ( $val ) = @_; 2494 my $checksum = uc substr(md5_hex($val), -16); 2495 PTDEBUG && _d($checksum, 'checksum for', $val); 2496 return $checksum; 2497} 2498 2499sub crc32 { 2500 my ( $string ) = @_; 2501 return unless $string; 2502 my $poly = 0xEDB88320; 2503 my $crc = 0xFFFFFFFF; 2504 foreach my $char ( split(//, $string) ) { 2505 my $comp = ($crc ^ ord($char)) & 0xFF; 2506 for ( 1 .. 8 ) { 2507 $comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1; 2508 } 2509 $crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp; 2510 } 2511 return $crc ^ 0xFFFFFFFF; 2512} 2513 2514my $got_json = eval { require JSON }; 2515sub encode_json { 2516 return JSON::encode_json(@_) if $got_json; 2517 my ( $data ) = @_; 2518 return (object_to_json($data) || ''); 2519} 2520 2521 2522sub object_to_json { 2523 my ($obj) = @_; 2524 my $type = ref($obj); 2525 2526 if($type eq 'HASH'){ 2527 return hash_to_json($obj); 2528 } 2529 elsif($type eq 'ARRAY'){ 2530 return array_to_json($obj); 2531 } 2532 else { 2533 return value_to_json($obj); 2534 } 2535} 2536 2537sub hash_to_json { 2538 my ($obj) = @_; 2539 my @res; 2540 for my $k ( sort { $a cmp $b } keys %$obj ) { 2541 push @res, string_to_json( $k ) 2542 . ":" 2543 . ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) ); 2544 } 2545 return '{' . ( @res ? join( ",", @res ) : '' ) . '}'; 2546} 2547 2548sub array_to_json { 2549 my ($obj) = @_; 2550 my @res; 2551 2552 for my $v (@$obj) { 2553 push @res, object_to_json($v) || value_to_json($v); 2554 } 2555 2556 return '[' . ( @res ? join( ",", @res ) : '' ) . ']'; 2557} 2558 2559sub value_to_json { 2560 my ($value) = @_; 2561 2562 return 'null' if(!defined $value); 2563 2564 my $b_obj = B::svref_2object(\$value); # for round trip problem 2565 my $flags = $b_obj->FLAGS; 2566 return $value # as is 2567 if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? 2568 2569 my $type = ref($value); 2570 2571 if( !$type ) { 2572 return string_to_json($value); 2573 } 2574 else { 2575 return 'null'; 2576 } 2577 2578} 2579 2580my %esc = ( 2581 "\n" => '\n', 2582 "\r" => '\r', 2583 "\t" => '\t', 2584 "\f" => '\f', 2585 "\b" => '\b', 2586 "\"" => '\"', 2587 "\\" => '\\\\', 2588 "\'" => '\\\'', 2589); 2590 2591sub string_to_json { 2592 my ($arg) = @_; 2593 2594 $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; 2595 $arg =~ s/\//\\\//g; 2596 $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; 2597 2598 utf8::upgrade($arg); 2599 utf8::encode($arg); 2600 2601 return '"' . $arg . '"'; 2602} 2603 2604sub _d { 2605 my ($package, undef, $line) = caller 0; 2606 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 2607 map { defined $_ ? $_ : 'undef' } 2608 @_; 2609 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 2610} 2611 26121; 2613} 2614# ########################################################################### 2615# End Transformers package 2616# ########################################################################### 2617 2618# ########################################################################### 2619# HTTP::Micro package 2620# This package is a copy without comments from the original. The original 2621# with comments and its test file can be found in the Bazaar repository at, 2622# lib/HTTP/Micro.pm 2623# t/lib/HTTP/Micro.t 2624# See https://launchpad.net/percona-toolkit for more information. 2625# ########################################################################### 2626{ 2627package HTTP::Micro; 2628 2629our $VERSION = '0.01'; 2630 2631use strict; 2632use warnings FATAL => 'all'; 2633use English qw(-no_match_vars); 2634use Carp (); 2635 2636my @attributes; 2637BEGIN { 2638 @attributes = qw(agent timeout); 2639 no strict 'refs'; 2640 for my $accessor ( @attributes ) { 2641 *{$accessor} = sub { 2642 @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor}; 2643 }; 2644 } 2645} 2646 2647sub new { 2648 my($class, %args) = @_; 2649 (my $agent = $class) =~ s{::}{-}g; 2650 my $self = { 2651 agent => $agent . "/" . ($class->VERSION || 0), 2652 timeout => 60, 2653 }; 2654 for my $key ( @attributes ) { 2655 $self->{$key} = $args{$key} if exists $args{$key} 2656 } 2657 return bless $self, $class; 2658} 2659 2660my %DefaultPort = ( 2661 http => 80, 2662 https => 443, 2663); 2664 2665sub request { 2666 my ($self, $method, $url, $args) = @_; 2667 @_ == 3 || (@_ == 4 && ref $args eq 'HASH') 2668 or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/); 2669 $args ||= {}; # we keep some state in this during _request 2670 2671 my $response; 2672 for ( 0 .. 1 ) { 2673 $response = eval { $self->_request($method, $url, $args) }; 2674 last unless $@ && $method eq 'GET' 2675 && $@ =~ m{^(?:Socket closed|Unexpected end)}; 2676 } 2677 2678 if (my $e = "$@") { 2679 $response = { 2680 success => q{}, 2681 status => 599, 2682 reason => 'Internal Exception', 2683 content => $e, 2684 headers => { 2685 'content-type' => 'text/plain', 2686 'content-length' => length $e, 2687 } 2688 }; 2689 } 2690 return $response; 2691} 2692 2693sub _request { 2694 my ($self, $method, $url, $args) = @_; 2695 2696 my ($scheme, $host, $port, $path_query) = $self->_split_url($url); 2697 2698 my $request = { 2699 method => $method, 2700 scheme => $scheme, 2701 host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), 2702 uri => $path_query, 2703 headers => {}, 2704 }; 2705 2706 my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout}); 2707 2708 $handle->connect($scheme, $host, $port); 2709 2710 $self->_prepare_headers_and_cb($request, $args); 2711 $handle->write_request_header(@{$request}{qw/method uri headers/}); 2712 $handle->write_content_body($request) if $request->{content}; 2713 2714 my $response; 2715 do { $response = $handle->read_response_header } 2716 until (substr($response->{status},0,1) ne '1'); 2717 2718 if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) { 2719 $response->{content} = ''; 2720 $handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response); 2721 } 2722 2723 $handle->close; 2724 $response->{success} = substr($response->{status},0,1) eq '2'; 2725 return $response; 2726} 2727 2728sub _prepare_headers_and_cb { 2729 my ($self, $request, $args) = @_; 2730 2731 for ($args->{headers}) { 2732 next unless defined; 2733 while (my ($k, $v) = each %$_) { 2734 $request->{headers}{lc $k} = $v; 2735 } 2736 } 2737 $request->{headers}{'host'} = $request->{host_port}; 2738 $request->{headers}{'connection'} = "close"; 2739 $request->{headers}{'user-agent'} ||= $self->{agent}; 2740 2741 if (defined $args->{content}) { 2742 $request->{headers}{'content-type'} ||= "application/octet-stream"; 2743 utf8::downgrade($args->{content}, 1) 2744 or Carp::croak(q/Wide character in request message body/); 2745 $request->{headers}{'content-length'} = length $args->{content}; 2746 $request->{content} = $args->{content}; 2747 } 2748 return; 2749} 2750 2751sub _split_url { 2752 my $url = pop; 2753 2754 my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> 2755 or Carp::croak(qq/Cannot parse URL: '$url'/); 2756 2757 $scheme = lc $scheme; 2758 $path_query = "/$path_query" unless $path_query =~ m<\A/>; 2759 2760 my $host = (length($authority)) ? lc $authority : 'localhost'; 2761 $host =~ s/\A[^@]*@//; # userinfo 2762 my $port = do { 2763 $host =~ s/:([0-9]*)\z// && length $1 2764 ? $1 2765 : $DefaultPort{$scheme} 2766 }; 2767 2768 return ($scheme, $host, $port, $path_query); 2769} 2770 2771} # HTTP::Micro 2772 2773{ 2774 package HTTP::Micro::Handle; 2775 2776 use strict; 2777 use warnings FATAL => 'all'; 2778 use English qw(-no_match_vars); 2779 2780 use Carp qw(croak); 2781 use Errno qw(EINTR EPIPE); 2782 use IO::Socket qw(SOCK_STREAM); 2783 2784 sub BUFSIZE () { 32768 } 2785 2786 my $Printable = sub { 2787 local $_ = shift; 2788 s/\r/\\r/g; 2789 s/\n/\\n/g; 2790 s/\t/\\t/g; 2791 s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; 2792 $_; 2793 }; 2794 2795 sub new { 2796 my ($class, %args) = @_; 2797 return bless { 2798 rbuf => '', 2799 timeout => 60, 2800 max_line_size => 16384, 2801 %args 2802 }, $class; 2803 } 2804 2805 my $ssl_verify_args = { 2806 check_cn => "when_only", 2807 wildcards_in_alt => "anywhere", 2808 wildcards_in_cn => "anywhere" 2809 }; 2810 2811 sub connect { 2812 @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); 2813 my ($self, $scheme, $host, $port) = @_; 2814 2815 if ( $scheme eq 'https' ) { 2816 eval "require IO::Socket::SSL" 2817 unless exists $INC{'IO/Socket/SSL.pm'}; 2818 croak(qq/IO::Socket::SSL must be installed for https support\n/) 2819 unless $INC{'IO/Socket/SSL.pm'}; 2820 } 2821 elsif ( $scheme ne 'http' ) { 2822 croak(qq/Unsupported URL scheme '$scheme'\n/); 2823 } 2824 2825 $self->{fh} = IO::Socket::INET->new( 2826 PeerHost => $host, 2827 PeerPort => $port, 2828 Proto => 'tcp', 2829 Type => SOCK_STREAM, 2830 Timeout => $self->{timeout} 2831 ) or croak(qq/Could not connect to '$host:$port': $@/); 2832 2833 binmode($self->{fh}) 2834 or croak(qq/Could not binmode() socket: '$!'/); 2835 2836 if ( $scheme eq 'https') { 2837 IO::Socket::SSL->start_SSL($self->{fh}); 2838 ref($self->{fh}) eq 'IO::Socket::SSL' 2839 or die(qq/SSL connection failed for $host\n/); 2840 if ( $self->{fh}->can("verify_hostname") ) { 2841 $self->{fh}->verify_hostname( $host, $ssl_verify_args ) 2842 or die(qq/SSL certificate not valid for $host\n/); 2843 } 2844 else { 2845 my $fh = $self->{fh}; 2846 _verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args) 2847 or die(qq/SSL certificate not valid for $host\n/); 2848 } 2849 } 2850 2851 $self->{host} = $host; 2852 $self->{port} = $port; 2853 2854 return $self; 2855 } 2856 2857 sub close { 2858 @_ == 1 || croak(q/Usage: $handle->close()/); 2859 my ($self) = @_; 2860 CORE::close($self->{fh}) 2861 or croak(qq/Could not close socket: '$!'/); 2862 } 2863 2864 sub write { 2865 @_ == 2 || croak(q/Usage: $handle->write(buf)/); 2866 my ($self, $buf) = @_; 2867 2868 my $len = length $buf; 2869 my $off = 0; 2870 2871 local $SIG{PIPE} = 'IGNORE'; 2872 2873 while () { 2874 $self->can_write 2875 or croak(q/Timed out while waiting for socket to become ready for writing/); 2876 my $r = syswrite($self->{fh}, $buf, $len, $off); 2877 if (defined $r) { 2878 $len -= $r; 2879 $off += $r; 2880 last unless $len > 0; 2881 } 2882 elsif ($! == EPIPE) { 2883 croak(qq/Socket closed by remote server: $!/); 2884 } 2885 elsif ($! != EINTR) { 2886 croak(qq/Could not write to socket: '$!'/); 2887 } 2888 } 2889 return $off; 2890 } 2891 2892 sub read { 2893 @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/); 2894 my ($self, $len) = @_; 2895 2896 my $buf = ''; 2897 my $got = length $self->{rbuf}; 2898 2899 if ($got) { 2900 my $take = ($got < $len) ? $got : $len; 2901 $buf = substr($self->{rbuf}, 0, $take, ''); 2902 $len -= $take; 2903 } 2904 2905 while ($len > 0) { 2906 $self->can_read 2907 or croak(q/Timed out while waiting for socket to become ready for reading/); 2908 my $r = sysread($self->{fh}, $buf, $len, length $buf); 2909 if (defined $r) { 2910 last unless $r; 2911 $len -= $r; 2912 } 2913 elsif ($! != EINTR) { 2914 croak(qq/Could not read from socket: '$!'/); 2915 } 2916 } 2917 if ($len) { 2918 croak(q/Unexpected end of stream/); 2919 } 2920 return $buf; 2921 } 2922 2923 sub readline { 2924 @_ == 1 || croak(q/Usage: $handle->readline()/); 2925 my ($self) = @_; 2926 2927 while () { 2928 if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { 2929 return $1; 2930 } 2931 $self->can_read 2932 or croak(q/Timed out while waiting for socket to become ready for reading/); 2933 my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); 2934 if (defined $r) { 2935 last unless $r; 2936 } 2937 elsif ($! != EINTR) { 2938 croak(qq/Could not read from socket: '$!'/); 2939 } 2940 } 2941 croak(q/Unexpected end of stream while looking for line/); 2942 } 2943 2944 sub read_header_lines { 2945 @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); 2946 my ($self, $headers) = @_; 2947 $headers ||= {}; 2948 my $lines = 0; 2949 my $val; 2950 2951 while () { 2952 my $line = $self->readline; 2953 2954 if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { 2955 my ($field_name) = lc $1; 2956 $val = \($headers->{$field_name} = $2); 2957 } 2958 elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { 2959 $val 2960 or croak(q/Unexpected header continuation line/); 2961 next unless length $1; 2962 $$val .= ' ' if length $$val; 2963 $$val .= $1; 2964 } 2965 elsif ($line =~ /\A \x0D?\x0A \z/x) { 2966 last; 2967 } 2968 else { 2969 croak(q/Malformed header line: / . $Printable->($line)); 2970 } 2971 } 2972 return $headers; 2973 } 2974 2975 sub write_header_lines { 2976 (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); 2977 my($self, $headers) = @_; 2978 2979 my $buf = ''; 2980 while (my ($k, $v) = each %$headers) { 2981 my $field_name = lc $k; 2982 $field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x 2983 or croak(q/Invalid HTTP header field name: / . $Printable->($field_name)); 2984 $field_name =~ s/\b(\w)/\u$1/g; 2985 $buf .= "$field_name: $v\x0D\x0A"; 2986 } 2987 $buf .= "\x0D\x0A"; 2988 return $self->write($buf); 2989 } 2990 2991 sub read_content_body { 2992 @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); 2993 my ($self, $cb, $response, $len) = @_; 2994 $len ||= $response->{headers}{'content-length'}; 2995 2996 croak("No content-length in the returned response, and this " 2997 . "UA doesn't implement chunking") unless defined $len; 2998 2999 while ($len > 0) { 3000 my $read = ($len > BUFSIZE) ? BUFSIZE : $len; 3001 $cb->($self->read($read), $response); 3002 $len -= $read; 3003 } 3004 3005 return; 3006 } 3007 3008 sub write_content_body { 3009 @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/); 3010 my ($self, $request) = @_; 3011 my ($len, $content_length) = (0, $request->{headers}{'content-length'}); 3012 3013 $len += $self->write($request->{content}); 3014 3015 $len == $content_length 3016 or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); 3017 3018 return $len; 3019 } 3020 3021 sub read_response_header { 3022 @_ == 1 || croak(q/Usage: $handle->read_response_header()/); 3023 my ($self) = @_; 3024 3025 my $line = $self->readline; 3026 3027 $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x 3028 or croak(q/Malformed Status-Line: / . $Printable->($line)); 3029 3030 my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); 3031 3032 return { 3033 status => $status, 3034 reason => $reason, 3035 headers => $self->read_header_lines, 3036 protocol => $protocol, 3037 }; 3038 } 3039 3040 sub write_request_header { 3041 @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/); 3042 my ($self, $method, $request_uri, $headers) = @_; 3043 3044 return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") 3045 + $self->write_header_lines($headers); 3046 } 3047 3048 sub _do_timeout { 3049 my ($self, $type, $timeout) = @_; 3050 $timeout = $self->{timeout} 3051 unless defined $timeout && $timeout >= 0; 3052 3053 my $fd = fileno $self->{fh}; 3054 defined $fd && $fd >= 0 3055 or croak(q/select(2): 'Bad file descriptor'/); 3056 3057 my $initial = time; 3058 my $pending = $timeout; 3059 my $nfound; 3060 3061 vec(my $fdset = '', $fd, 1) = 1; 3062 3063 while () { 3064 $nfound = ($type eq 'read') 3065 ? select($fdset, undef, undef, $pending) 3066 : select(undef, $fdset, undef, $pending) ; 3067 if ($nfound == -1) { 3068 $! == EINTR 3069 or croak(qq/select(2): '$!'/); 3070 redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; 3071 $nfound = 0; 3072 } 3073 last; 3074 } 3075 $! = 0; 3076 return $nfound; 3077 } 3078 3079 sub can_read { 3080 @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/); 3081 my $self = shift; 3082 return $self->_do_timeout('read', @_) 3083 } 3084 3085 sub can_write { 3086 @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/); 3087 my $self = shift; 3088 return $self->_do_timeout('write', @_) 3089 } 3090} # HTTP::Micro::Handle 3091 3092my $prog = <<'EOP'; 3093BEGIN { 3094 if ( defined &IO::Socket::SSL::CAN_IPV6 ) { 3095 *CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6; 3096 } 3097 else { 3098 constant->import( CAN_IPV6 => '' ); 3099 } 3100 my %const = ( 3101 NID_CommonName => 13, 3102 GEN_DNS => 2, 3103 GEN_IPADD => 7, 3104 ); 3105 while ( my ($name,$value) = each %const ) { 3106 no strict 'refs'; 3107 *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value }; 3108 } 3109} 3110{ 3111 use Carp qw(croak); 3112 my %dispatcher = ( 3113 issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) }, 3114 subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) }, 3115 ); 3116 if ( $Net::SSLeay::VERSION >= 1.30 ) { 3117 $dispatcher{commonName} = sub { 3118 my $cn = Net::SSLeay::X509_NAME_get_text_by_NID( 3119 Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName); 3120 $cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33 3121 $cn; 3122 } 3123 } else { 3124 $dispatcher{commonName} = sub { 3125 croak "you need at least Net::SSLeay version 1.30 for getting commonName" 3126 } 3127 } 3128 3129 if ( $Net::SSLeay::VERSION >= 1.33 ) { 3130 $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; 3131 } else { 3132 $dispatcher{subjectAltNames} = sub { 3133 return; 3134 }; 3135 } 3136 3137 $dispatcher{authority} = $dispatcher{issuer}; 3138 $dispatcher{owner} = $dispatcher{subject}; 3139 $dispatcher{cn} = $dispatcher{commonName}; 3140 3141 sub _peer_certificate { 3142 my ($self, $field) = @_; 3143 my $ssl = $self->_get_ssl_object or return; 3144 3145 my $cert = ${*$self}{_SSL_certificate} 3146 ||= Net::SSLeay::get_peer_certificate($ssl) 3147 or return $self->error("Could not retrieve peer certificate"); 3148 3149 if ($field) { 3150 my $sub = $dispatcher{$field} or croak 3151 "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ). 3152 "\nMaybe you need to upgrade your Net::SSLeay"; 3153 return $sub->($cert); 3154 } else { 3155 return $cert 3156 } 3157 } 3158 3159 3160 my %scheme = ( 3161 ldap => { 3162 wildcards_in_cn => 0, 3163 wildcards_in_alt => 'leftmost', 3164 check_cn => 'always', 3165 }, 3166 http => { 3167 wildcards_in_cn => 'anywhere', 3168 wildcards_in_alt => 'anywhere', 3169 check_cn => 'when_only', 3170 }, 3171 smtp => { 3172 wildcards_in_cn => 0, 3173 wildcards_in_alt => 0, 3174 check_cn => 'always' 3175 }, 3176 none => {}, # do not check 3177 ); 3178 3179 $scheme{www} = $scheme{http}; # alias 3180 $scheme{xmpp} = $scheme{http}; # rfc 3920 3181 $scheme{pop3} = $scheme{ldap}; # rfc 2595 3182 $scheme{imap} = $scheme{ldap}; # rfc 2595 3183 $scheme{acap} = $scheme{ldap}; # rfc 2595 3184 $scheme{nntp} = $scheme{ldap}; # rfc 4642 3185 $scheme{ftp} = $scheme{http}; # rfc 4217 3186 3187 3188 sub _verify_hostname_of_cert { 3189 my $identity = shift; 3190 my $cert = shift; 3191 my $scheme = shift || 'none'; 3192 if ( ! ref($scheme) ) { 3193 $scheme = $scheme{$scheme} or croak "scheme $scheme not defined"; 3194 } 3195 3196 return 1 if ! %$scheme; # 'none' 3197 3198 my $commonName = $dispatcher{cn}->($cert); 3199 my @altNames = $dispatcher{subjectAltNames}->($cert); 3200 3201 if ( my $sub = $scheme->{callback} ) { 3202 return $sub->($identity,$commonName,@altNames); 3203 } 3204 3205 3206 my $ipn; 3207 if ( CAN_IPV6 and $identity =~m{:} ) { 3208 $ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity) 3209 or croak "'$identity' is not IPv6, but neither IPv4 nor hostname"; 3210 } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) { 3211 $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; 3212 } else { 3213 if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) { 3214 $identity =~m{\0} and croak("name '$identity' has \\0 byte"); 3215 $identity = IO::Socket::SSL::idn_to_ascii($identity) or 3216 croak "Warning: Given name '$identity' could not be converted to IDNA!"; 3217 } 3218 } 3219 3220 my $check_name = sub { 3221 my ($name,$identity,$wtyp) = @_; 3222 $wtyp ||= ''; 3223 my $pattern; 3224 if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) { 3225 $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i; 3226 } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) { 3227 $pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i; 3228 } else { 3229 $pattern = qr{^\Q$name\E$}i; 3230 } 3231 return $identity =~ $pattern; 3232 }; 3233 3234 my $alt_dnsNames = 0; 3235 while (@altNames) { 3236 my ($type, $name) = splice (@altNames, 0, 2); 3237 if ( $ipn and $type == GEN_IPADD ) { 3238 return 1 if $ipn eq $name; 3239 3240 } elsif ( ! $ipn and $type == GEN_DNS ) { 3241 $name =~s/\s+$//; $name =~s/^\s+//; 3242 $alt_dnsNames++; 3243 $check_name->($name,$identity,$scheme->{wildcards_in_alt}) 3244 and return 1; 3245 } 3246 } 3247 3248 if ( ! $ipn and ( 3249 $scheme->{check_cn} eq 'always' or 3250 $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) { 3251 $check_name->($commonName,$identity,$scheme->{wildcards_in_cn}) 3252 and return 1; 3253 } 3254 3255 return 0; # no match 3256 } 3257} 3258EOP 3259 3260eval { require IO::Socket::SSL }; 3261if ( $INC{"IO/Socket/SSL.pm"} ) { 3262 eval $prog; 3263 die $@ if $@; 3264} 3265 32661; 3267# ########################################################################### 3268# End HTTP::Micro package 3269# ########################################################################### 3270 3271# ########################################################################### 3272# VersionCheck package 3273# This package is a copy without comments from the original. The original 3274# with comments and its test file can be found in the Bazaar repository at, 3275# lib/VersionCheck.pm 3276# t/lib/VersionCheck.t 3277# See https://launchpad.net/percona-toolkit for more information. 3278# ########################################################################### 3279{ 3280package VersionCheck; 3281 3282 3283use strict; 3284use warnings FATAL => 'all'; 3285use English qw(-no_match_vars); 3286 3287use constant PTDEBUG => $ENV{PTDEBUG} || 0; 3288 3289use Data::Dumper; 3290local $Data::Dumper::Indent = 1; 3291local $Data::Dumper::Sortkeys = 1; 3292local $Data::Dumper::Quotekeys = 0; 3293 3294use Digest::MD5 qw(md5_hex); 3295use Sys::Hostname qw(hostname); 3296use File::Basename qw(); 3297use File::Spec; 3298use FindBin qw(); 3299 3300eval { 3301 require Percona::Toolkit; 3302 require HTTP::Micro; 3303}; 3304 3305my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.'; 3306my @vc_dirs = ( 3307 '/etc/percona', 3308 '/etc/percona-toolkit', 3309 '/tmp', 3310 "$home", 3311); 3312 3313{ 3314 my $file = 'percona-version-check'; 3315 3316 sub version_check_file { 3317 foreach my $dir ( @vc_dirs ) { 3318 if ( -d $dir && -w $dir ) { 3319 PTDEBUG && _d('Version check file', $file, 'in', $dir); 3320 return $dir . '/' . $file; 3321 } 3322 } 3323 PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD}); 3324 return $file; # in the CWD 3325 } 3326} 3327 3328sub version_check_time_limit { 3329 return 60 * 60 * 24; # one day 3330} 3331 3332 3333sub version_check { 3334 my (%args) = @_; 3335 3336 my $instances = $args{instances} || []; 3337 my $instances_to_check; 3338 3339 PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin); 3340 if ( !$args{force} ) { 3341 if ( $FindBin::Bin 3342 && (-d "$FindBin::Bin/../.bzr" || 3343 -d "$FindBin::Bin/../../.bzr" || 3344 -d "$FindBin::Bin/../.git" || 3345 -d "$FindBin::Bin/../../.git" 3346 ) 3347 ) { 3348 PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check"); 3349 return; 3350 } 3351 } 3352 3353 eval { 3354 foreach my $instance ( @$instances ) { 3355 my ($name, $id) = get_instance_id($instance); 3356 $instance->{name} = $name; 3357 $instance->{id} = $id; 3358 } 3359 3360 push @$instances, { name => 'system', id => 0 }; 3361 3362 $instances_to_check = get_instances_to_check( 3363 instances => $instances, 3364 vc_file => $args{vc_file}, # testing 3365 now => $args{now}, # testing 3366 ); 3367 PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); 3368 return unless @$instances_to_check; 3369 3370 my $protocol = 'https'; 3371 eval { require IO::Socket::SSL; }; 3372 if ( $EVAL_ERROR ) { 3373 PTDEBUG && _d($EVAL_ERROR); 3374 PTDEBUG && _d("SSL not available, won't run version_check"); 3375 return; 3376 } 3377 PTDEBUG && _d('Using', $protocol); 3378 3379 my $advice = pingback( 3380 instances => $instances_to_check, 3381 protocol => $protocol, 3382 url => $args{url} # testing 3383 || $ENV{PERCONA_VERSION_CHECK_URL} # testing 3384 || "$protocol://v.percona.com", 3385 ); 3386 if ( $advice ) { 3387 PTDEBUG && _d('Advice:', Dumper($advice)); 3388 if ( scalar @$advice > 1) { 3389 print "\n# " . scalar @$advice . " software updates are " 3390 . "available:\n"; 3391 } 3392 else { 3393 print "\n# A software update is available:\n"; 3394 } 3395 print join("\n", map { "# * $_" } @$advice), "\n\n"; 3396 } 3397 }; 3398 if ( $EVAL_ERROR ) { 3399 PTDEBUG && _d('Version check failed:', $EVAL_ERROR); 3400 } 3401 3402 if ( @$instances_to_check ) { 3403 eval { 3404 update_check_times( 3405 instances => $instances_to_check, 3406 vc_file => $args{vc_file}, # testing 3407 now => $args{now}, # testing 3408 ); 3409 }; 3410 if ( $EVAL_ERROR ) { 3411 PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR); 3412 } 3413 } 3414 3415 if ( $ENV{PTDEBUG_VERSION_CHECK} ) { 3416 warn "Exiting because the PTDEBUG_VERSION_CHECK " 3417 . "environment variable is defined.\n"; 3418 exit 255; 3419 } 3420 3421 return; 3422} 3423 3424sub get_instances_to_check { 3425 my (%args) = @_; 3426 3427 my $instances = $args{instances}; 3428 my $now = $args{now} || int(time); 3429 my $vc_file = $args{vc_file} || version_check_file(); 3430 3431 if ( !-f $vc_file ) { 3432 PTDEBUG && _d('Version check file', $vc_file, 'does not exist;', 3433 'version checking all instances'); 3434 return $instances; 3435 } 3436 3437 open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; 3438 chomp(my $file_contents = do { local $/ = undef; <$fh> }); 3439 PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents); 3440 close $fh; 3441 my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; 3442 3443 my $check_time_limit = version_check_time_limit(); 3444 my @instances_to_check; 3445 foreach my $instance ( @$instances ) { 3446 my $last_check_time = $last_check_time_for{ $instance->{id} }; 3447 PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', 3448 $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0), 3449 'hours until next check', 3450 sprintf '%.2f', 3451 ($check_time_limit - ($now - ($last_check_time || 0))) / 3600); 3452 if ( !defined $last_check_time 3453 || ($now - $last_check_time) >= $check_time_limit ) { 3454 PTDEBUG && _d('Time to check', Dumper($instance)); 3455 push @instances_to_check, $instance; 3456 } 3457 } 3458 3459 return \@instances_to_check; 3460} 3461 3462sub update_check_times { 3463 my (%args) = @_; 3464 3465 my $instances = $args{instances}; 3466 my $now = $args{now} || int(time); 3467 my $vc_file = $args{vc_file} || version_check_file(); 3468 PTDEBUG && _d('Updating last check time:', $now); 3469 3470 my %all_instances = map { 3471 $_->{id} => { name => $_->{name}, ts => $now } 3472 } @$instances; 3473 3474 if ( -f $vc_file ) { 3475 open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR"; 3476 my $contents = do { local $/ = undef; <$fh> }; 3477 close $fh; 3478 3479 foreach my $line ( split("\n", ($contents || '')) ) { 3480 my ($id, $ts) = split(',', $line); 3481 if ( !exists $all_instances{$id} ) { 3482 $all_instances{$id} = { ts => $ts }; # original ts, not updated 3483 } 3484 } 3485 } 3486 3487 open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; 3488 foreach my $id ( sort keys %all_instances ) { 3489 PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id})); 3490 print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n"; 3491 } 3492 close $fh; 3493 3494 return; 3495} 3496 3497sub get_instance_id { 3498 my ($instance) = @_; 3499 3500 my $dbh = $instance->{dbh}; 3501 my $dsn = $instance->{dsn}; 3502 3503 my $sql = q{SELECT CONCAT(@@hostname, @@port)}; 3504 PTDEBUG && _d($sql); 3505 my ($name) = eval { $dbh->selectrow_array($sql) }; 3506 if ( $EVAL_ERROR ) { 3507 PTDEBUG && _d($EVAL_ERROR); 3508 $sql = q{SELECT @@hostname}; 3509 PTDEBUG && _d($sql); 3510 ($name) = eval { $dbh->selectrow_array($sql) }; 3511 if ( $EVAL_ERROR ) { 3512 PTDEBUG && _d($EVAL_ERROR); 3513 $name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306); 3514 } 3515 else { 3516 $sql = q{SHOW VARIABLES LIKE 'port'}; 3517 PTDEBUG && _d($sql); 3518 my (undef, $port) = eval { $dbh->selectrow_array($sql) }; 3519 PTDEBUG && _d('port:', $port); 3520 $name .= $port || ''; 3521 } 3522 } 3523 my $id = md5_hex($name); 3524 3525 PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn)); 3526 3527 return $name, $id; 3528} 3529 3530 3531sub get_uuid { 3532 my $uuid_file = '/.percona-toolkit.uuid'; 3533 foreach my $dir (@vc_dirs) { 3534 my $filename = $dir.$uuid_file; 3535 my $uuid=_read_uuid($filename); 3536 return $uuid if $uuid; 3537 } 3538 3539 my $filename = $ENV{"HOME"} . $uuid_file; 3540 my $uuid = _generate_uuid(); 3541 3542 open(my $fh, '>', $filename) or die "Could not open file '$filename' $!"; 3543 print $fh $uuid; 3544 close $fh; 3545 3546 return $uuid; 3547} 3548 3549sub _generate_uuid { 3550 return sprintf+($}="%04x")."$}-$}-$}-$}-".$}x3,map rand 65537,0..7; 3551} 3552 3553sub _read_uuid { 3554 my $filename = shift; 3555 my $fh; 3556 3557 eval { 3558 open($fh, '<:encoding(UTF-8)', $filename); 3559 }; 3560 return if ($EVAL_ERROR); 3561 3562 my $uuid; 3563 eval { $uuid = <$fh>; }; 3564 return if ($EVAL_ERROR); 3565 3566 chomp $uuid; 3567 return $uuid; 3568} 3569 3570 3571sub pingback { 3572 my (%args) = @_; 3573 my @required_args = qw(url instances); 3574 foreach my $arg ( @required_args ) { 3575 die "I need a $arg arugment" unless $args{$arg}; 3576 } 3577 my $url = $args{url}; 3578 my $instances = $args{instances}; 3579 3580 my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 ); 3581 3582 my $response = $ua->request('GET', $url); 3583 PTDEBUG && _d('Server response:', Dumper($response)); 3584 die "No response from GET $url" 3585 if !$response; 3586 die("GET on $url returned HTTP status $response->{status}; expected 200\n", 3587 ($response->{content} || '')) if $response->{status} != 200; 3588 die("GET on $url did not return any programs to check") 3589 if !$response->{content}; 3590 3591 my $items = parse_server_response( 3592 response => $response->{content} 3593 ); 3594 die "Failed to parse server requested programs: $response->{content}" 3595 if !scalar keys %$items; 3596 3597 my $versions = get_versions( 3598 items => $items, 3599 instances => $instances, 3600 ); 3601 die "Failed to get any program versions; should have at least gotten Perl" 3602 if !scalar keys %$versions; 3603 3604 my $client_content = encode_client_response( 3605 items => $items, 3606 versions => $versions, 3607 general_id => get_uuid(), 3608 ); 3609 3610 my $client_response = { 3611 headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, 3612 content => $client_content, 3613 }; 3614 PTDEBUG && _d('Client response:', Dumper($client_response)); 3615 3616 $response = $ua->request('POST', $url, $client_response); 3617 PTDEBUG && _d('Server suggestions:', Dumper($response)); 3618 die "No response from POST $url $client_response" 3619 if !$response; 3620 die "POST $url returned HTTP status $response->{status}; expected 200" 3621 if $response->{status} != 200; 3622 3623 return unless $response->{content}; 3624 3625 $items = parse_server_response( 3626 response => $response->{content}, 3627 split_vars => 0, 3628 ); 3629 die "Failed to parse server suggestions: $response->{content}" 3630 if !scalar keys %$items; 3631 my @suggestions = map { $_->{vars} } 3632 sort { $a->{item} cmp $b->{item} } 3633 values %$items; 3634 3635 return \@suggestions; 3636} 3637 3638sub encode_client_response { 3639 my (%args) = @_; 3640 my @required_args = qw(items versions general_id); 3641 foreach my $arg ( @required_args ) { 3642 die "I need a $arg arugment" unless $args{$arg}; 3643 } 3644 my ($items, $versions, $general_id) = @args{@required_args}; 3645 3646 my @lines; 3647 foreach my $item ( sort keys %$items ) { 3648 next unless exists $versions->{$item}; 3649 if ( ref($versions->{$item}) eq 'HASH' ) { 3650 my $mysql_versions = $versions->{$item}; 3651 for my $id ( sort keys %$mysql_versions ) { 3652 push @lines, join(';', $id, $item, $mysql_versions->{$id}); 3653 } 3654 } 3655 else { 3656 push @lines, join(';', $general_id, $item, $versions->{$item}); 3657 } 3658 } 3659 3660 my $client_response = join("\n", @lines) . "\n"; 3661 return $client_response; 3662} 3663 3664sub parse_server_response { 3665 my (%args) = @_; 3666 my @required_args = qw(response); 3667 foreach my $arg ( @required_args ) { 3668 die "I need a $arg arugment" unless $args{$arg}; 3669 } 3670 my ($response) = @args{@required_args}; 3671 3672 my %items = map { 3673 my ($item, $type, $vars) = split(";", $_); 3674 if ( !defined $args{split_vars} || $args{split_vars} ) { 3675 $vars = [ split(",", ($vars || '')) ]; 3676 } 3677 $item => { 3678 item => $item, 3679 type => $type, 3680 vars => $vars, 3681 }; 3682 } split("\n", $response); 3683 3684 PTDEBUG && _d('Items:', Dumper(\%items)); 3685 3686 return \%items; 3687} 3688 3689my %sub_for_type = ( 3690 os_version => \&get_os_version, 3691 perl_version => \&get_perl_version, 3692 perl_module_version => \&get_perl_module_version, 3693 mysql_variable => \&get_mysql_variable, 3694); 3695 3696sub valid_item { 3697 my ($item) = @_; 3698 return unless $item; 3699 if ( !exists $sub_for_type{ $item->{type} } ) { 3700 PTDEBUG && _d('Invalid type:', $item->{type}); 3701 return 0; 3702 } 3703 return 1; 3704} 3705 3706sub get_versions { 3707 my (%args) = @_; 3708 my @required_args = qw(items); 3709 foreach my $arg ( @required_args ) { 3710 die "I need a $arg arugment" unless $args{$arg}; 3711 } 3712 my ($items) = @args{@required_args}; 3713 3714 my %versions; 3715 foreach my $item ( values %$items ) { 3716 next unless valid_item($item); 3717 eval { 3718 my $version = $sub_for_type{ $item->{type} }->( 3719 item => $item, 3720 instances => $args{instances}, 3721 ); 3722 if ( $version ) { 3723 chomp $version unless ref($version); 3724 $versions{$item->{item}} = $version; 3725 } 3726 }; 3727 if ( $EVAL_ERROR ) { 3728 PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR); 3729 } 3730 } 3731 3732 return \%versions; 3733} 3734 3735 3736sub get_os_version { 3737 if ( $OSNAME eq 'MSWin32' ) { 3738 require Win32; 3739 return Win32::GetOSDisplayName(); 3740 } 3741 3742 chomp(my $platform = `uname -s`); 3743 PTDEBUG && _d('platform:', $platform); 3744 return $OSNAME unless $platform; 3745 3746 chomp(my $lsb_release 3747 = `which lsb_release 2>/dev/null | awk '{print \$1}'` || ''); 3748 PTDEBUG && _d('lsb_release:', $lsb_release); 3749 3750 my $release = ""; 3751 3752 if ( $platform eq 'Linux' ) { 3753 if ( -f "/etc/fedora-release" ) { 3754 $release = `cat /etc/fedora-release`; 3755 } 3756 elsif ( -f "/etc/redhat-release" ) { 3757 $release = `cat /etc/redhat-release`; 3758 } 3759 elsif ( -f "/etc/system-release" ) { 3760 $release = `cat /etc/system-release`; 3761 } 3762 elsif ( $lsb_release ) { 3763 $release = `$lsb_release -ds`; 3764 } 3765 elsif ( -f "/etc/lsb-release" ) { 3766 $release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`; 3767 $release =~ s/^\w+="([^"]+)".+/$1/; 3768 } 3769 elsif ( -f "/etc/debian_version" ) { 3770 chomp(my $rel = `cat /etc/debian_version`); 3771 $release = "Debian $rel"; 3772 if ( -f "/etc/apt/sources.list" ) { 3773 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}'`); 3774 $release .= " ($code_name)" if $code_name; 3775 } 3776 } 3777 elsif ( -f "/etc/os-release" ) { # openSUSE 3778 chomp($release = `grep PRETTY_NAME /etc/os-release`); 3779 $release =~ s/^PRETTY_NAME="(.+)"$/$1/; 3780 } 3781 elsif ( `ls /etc/*release 2>/dev/null` ) { 3782 if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) { 3783 $release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`; 3784 } 3785 else { 3786 $release = `cat /etc/*release | head -n1`; 3787 } 3788 } 3789 } 3790 elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) { 3791 my $rel = `uname -r`; 3792 $release = "$platform $rel"; 3793 } 3794 elsif ( $platform eq "SunOS" ) { 3795 my $rel = `head -n1 /etc/release` || `uname -r`; 3796 $release = "$platform $rel"; 3797 } 3798 3799 if ( !$release ) { 3800 PTDEBUG && _d('Failed to get the release, using platform'); 3801 $release = $platform; 3802 } 3803 chomp($release); 3804 3805 $release =~ s/^"|"$//g; 3806 3807 PTDEBUG && _d('OS version =', $release); 3808 return $release; 3809} 3810 3811sub get_perl_version { 3812 my (%args) = @_; 3813 my $item = $args{item}; 3814 return unless $item; 3815 3816 my $version = sprintf '%vd', $PERL_VERSION; 3817 PTDEBUG && _d('Perl version', $version); 3818 return $version; 3819} 3820 3821sub get_perl_module_version { 3822 my (%args) = @_; 3823 my $item = $args{item}; 3824 return unless $item; 3825 3826 my $var = '$' . $item->{item} . '::VERSION'; 3827 my $version = eval "use $item->{item}; $var;"; 3828 PTDEBUG && _d('Perl version for', $var, '=', $version); 3829 return $version; 3830} 3831 3832sub get_mysql_variable { 3833 return get_from_mysql( 3834 show => 'VARIABLES', 3835 @_, 3836 ); 3837} 3838 3839sub get_from_mysql { 3840 my (%args) = @_; 3841 my $show = $args{show}; 3842 my $item = $args{item}; 3843 my $instances = $args{instances}; 3844 return unless $show && $item; 3845 3846 if ( !$instances || !@$instances ) { 3847 PTDEBUG && _d('Cannot check', $item, 3848 'because there are no MySQL instances'); 3849 return; 3850 } 3851 3852 if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') { 3853 @{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}}; 3854 } 3855 3856 3857 my @versions; 3858 my %version_for; 3859 foreach my $instance ( @$instances ) { 3860 next unless $instance->{id}; # special system instance has id=0 3861 my $dbh = $instance->{dbh}; 3862 local $dbh->{FetchHashKeyName} = 'NAME_lc'; 3863 my $sql = qq/SHOW $show/; 3864 PTDEBUG && _d($sql); 3865 my $rows = $dbh->selectall_hashref($sql, 'variable_name'); 3866 3867 my @versions; 3868 foreach my $var ( @{$item->{vars}} ) { 3869 $var = lc($var); 3870 my $version = $rows->{$var}->{value}; 3871 PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version, 3872 'on', $instance->{name}); 3873 push @versions, $version; 3874 } 3875 $version_for{ $instance->{id} } = join(' ', @versions); 3876 } 3877 3878 return \%version_for; 3879} 3880 3881sub _d { 3882 my ($package, undef, $line) = caller 0; 3883 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 3884 map { defined $_ ? $_ : 'undef' } 3885 @_; 3886 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 3887} 3888 38891; 3890} 3891# ########################################################################### 3892# End VersionCheck package 3893# ########################################################################### 3894 3895# ########################################################################### 3896# Runtime package 3897# This package is a copy without comments from the original. The original 3898# with comments and its test file can be found in the Bazaar repository at, 3899# lib/Runtime.pm 3900# t/lib/Runtime.t 3901# See https://launchpad.net/percona-toolkit for more information. 3902# ########################################################################### 3903{ 3904package Runtime; 3905 3906use strict; 3907use warnings FATAL => 'all'; 3908use English qw(-no_match_vars); 3909use constant PTDEBUG => $ENV{PTDEBUG} || 0; 3910 3911sub new { 3912 my ( $class, %args ) = @_; 3913 my @required_args = qw(now); 3914 foreach my $arg ( @required_args ) { 3915 die "I need a $arg argument" unless exists $args{$arg}; 3916 } 3917 3918 my $run_time = $args{run_time}; 3919 if ( defined $run_time ) { 3920 die "run_time must be > 0" if $run_time <= 0; 3921 } 3922 3923 my $now = $args{now}; 3924 die "now must be a callback" unless ref $now eq 'CODE'; 3925 3926 my $self = { 3927 run_time => $run_time, 3928 now => $now, 3929 start_time => undef, 3930 end_time => undef, 3931 time_left => undef, 3932 stop => 0, 3933 }; 3934 3935 return bless $self, $class; 3936} 3937 3938sub time_left { 3939 my ( $self, %args ) = @_; 3940 3941 if ( $self->{stop} ) { 3942 PTDEBUG && _d("No time left because stop was called"); 3943 return 0; 3944 } 3945 3946 my $now = $self->{now}->(%args); 3947 PTDEBUG && _d("Current time:", $now); 3948 3949 if ( !defined $self->{start_time} ) { 3950 $self->{start_time} = $now; 3951 } 3952 3953 return unless defined $now; 3954 3955 my $run_time = $self->{run_time}; 3956 return unless defined $run_time; 3957 3958 if ( !$self->{end_time} ) { 3959 $self->{end_time} = $now + $run_time; 3960 PTDEBUG && _d("End time:", $self->{end_time}); 3961 } 3962 3963 $self->{time_left} = $self->{end_time} - $now; 3964 PTDEBUG && _d("Time left:", $self->{time_left}); 3965 return $self->{time_left}; 3966} 3967 3968sub have_time { 3969 my ( $self, %args ) = @_; 3970 my $time_left = $self->time_left(%args); 3971 return 1 if !defined $time_left; # run forever 3972 return $time_left <= 0 ? 0 : 1; # <=0s means run time has elapsed 3973} 3974 3975sub time_elapsed { 3976 my ( $self, %args ) = @_; 3977 3978 my $start_time = $self->{start_time}; 3979 return 0 unless $start_time; 3980 3981 my $now = $self->{now}->(%args); 3982 PTDEBUG && _d("Current time:", $now); 3983 3984 my $time_elapsed = $now - $start_time; 3985 PTDEBUG && _d("Time elapsed:", $time_elapsed); 3986 if ( $time_elapsed < 0 ) { 3987 warn "Current time $now is earlier than start time $start_time"; 3988 } 3989 return $time_elapsed; 3990} 3991 3992sub reset { 3993 my ( $self ) = @_; 3994 $self->{start_time} = undef; 3995 $self->{end_time} = undef; 3996 $self->{time_left} = undef; 3997 $self->{stop} = 0; 3998 PTDEBUG && _d("Reset run time"); 3999 return; 4000} 4001 4002sub stop { 4003 my ( $self ) = @_; 4004 $self->{stop} = 1; 4005 return; 4006} 4007 4008sub start { 4009 my ( $self ) = @_; 4010 $self->{stop} = 0; 4011 return; 4012} 4013 4014sub _d { 4015 my ($package, undef, $line) = caller 0; 4016 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 4017 map { defined $_ ? $_ : 'undef' } 4018 @_; 4019 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 4020} 4021 40221; 4023} 4024# ########################################################################### 4025# End Runtime package 4026# ########################################################################### 4027 4028# ########################################################################### 4029# This is a combination of modules and programs in one -- a runnable module. 4030# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last 4031# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition. 4032# 4033# Check at the end of this package for the call to main() which actually runs 4034# the program. 4035# ########################################################################### 4036package pt_fk_error_logger; 4037 4038use strict; 4039use warnings FATAL => 'all'; 4040use English qw(-no_match_vars); 4041 4042use sigtrap 'handler', \&sig_int, 'normal-signals'; 4043 4044use Percona::Toolkit; 4045use constant PTDEBUG => $ENV{PTDEBUG} || 0; 4046 4047Transformers->import(qw(parse_timestamp)); 4048 4049my $oktorun = 1; 4050my $exit_status = 0; 4051 4052sub main { 4053 local @ARGV = @_; # set global ARGV for this package 4054 $oktorun = 1; 4055 $exit_status = 0; 4056 4057 # ######################################################################## 4058 # Get configuration information. 4059 # ######################################################################## 4060 my $o = new OptionParser(); 4061 $o->get_specs(); 4062 $o->get_opts(); 4063 4064 my $dp = $o->DSNParser(); 4065 $dp->prop('set-vars', $o->set_vars()); 4066 4067 my $src; 4068 if ( my $src_dsn_string = shift @ARGV ) { 4069 $src = Cxn->new( 4070 dsn_string => $src_dsn_string, 4071 parent => $o->get('daemonize'), 4072 DSNParser => $dp, 4073 OptionParser => $o, 4074 ); 4075 } 4076 4077 my $dst; 4078 if ( my $dst_dsn = $o->get('dest') ) { 4079 $dst = Cxn->new( 4080 dsn => $dst_dsn, 4081 prev_dsn => ($src ? $src->dsn : undef), 4082 parent => $o->get('daemonize'), 4083 DSNParser => $dp, 4084 OptionParser => $o, 4085 ); 4086 } 4087 4088 if ( !$o->get('help') ) { 4089 if ( !$src ) { 4090 $o->save_error('No DSN was specified.'); 4091 } 4092 if ( $dst && !$dst->dsn->{D} ) { 4093 $o->save_error("--dest requires a 'D' (database) part."); 4094 } 4095 if ( $dst && !$dst->dsn->{t} ) { 4096 $o->save_error("--dest requires a 't' (table) part."); 4097 } 4098 } 4099 4100 $o->usage_or_errors(); 4101 4102 # ######################################################################## 4103 # Connect to MySQL. 4104 # ######################################################################## 4105 my $q = Quoter->new(); 4106 4107 $src->connect(); 4108 4109 my $ins_sth; 4110 if ( $dst ) { 4111 $dst->connect(); 4112 my $db_tbl = $q->join_quote($dst->dsn->{D}, $dst->dsn->{t}); 4113 my $sql = "INSERT IGNORE INTO $db_tbl VALUES (?, ?)"; 4114 PTDEBUG && _d('--dest INSERT SQL:', $sql); 4115 $ins_sth = $dst->dbh->prepare($sql); 4116 } 4117 4118 # ######################################################################## 4119 # Daemonize only after (potentially) asking for passwords for --ask-pass. 4120 # ######################################################################## 4121 my $daemon; 4122 if ( $o->get('daemonize') ) { 4123 $daemon = new Daemon(o=>$o); 4124 $daemon->daemonize(); 4125 PTDEBUG && _d('I am a daemon now'); 4126 } 4127 elsif ( $o->get('pid') ) { 4128 # We're not daemoninzing, it just handles PID stuff. 4129 $daemon = new Daemon(o=>$o); 4130 $daemon->make_PID_file(); 4131 } 4132 4133 # If we daemonized, the parent has already exited and we're the child. 4134 # We shared a copy of every Cxn with the parent, and the parent's copies 4135 # were destroyed but the dbhs were not disconnected because the parent 4136 # attrib was true. Now, as the child, set it false so the dbhs will be 4137 # disconnected when our Cxn copies are destroyed. If we didn't daemonize, 4138 # then we're not really a parent (since we have no children), so set it 4139 # false to auto-disconnect the dbhs when our Cxns are destroyed. 4140 $src->{parent} = 0; 4141 $dst->{parent} = 0 if $dst; 4142 4143 # ######################################################################## 4144 # Do the version-check 4145 # ######################################################################## 4146 if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) { 4147 VersionCheck::version_check( 4148 force => $o->got('version-check'), 4149 instances => [ 4150 { dbh => $src->dbh, dsn => $src->dsn }, 4151 ($dst ? { dbh => $dst->dbh, dsn => $dst->dsn } : ()) 4152 ], 4153 ); 4154 } 4155 4156 # ######################################################################## 4157 # Start finding and logging foreign key errors. 4158 # ######################################################################## 4159 my $run_time = Runtime->new( 4160 run_time => $o->get('run-time'), 4161 now => sub { return time }, 4162 ); 4163 4164 my $interval = $o->get('interval'); 4165 my $iters = $o->get('iterations'); 4166 PTDEBUG && _d('iterations:', $iters, 'interval:', $interval); 4167 4168 ITERATION: 4169 while ( 4170 $oktorun 4171 && $run_time->have_time() 4172 && (!defined $iters || $iters--) 4173 ) { 4174 my ($ts, $fk_error); 4175 eval { 4176 my $sql = "SHOW /*!40100 ENGINE*/ INNODB STATUS " 4177 . "/* pt-fk-error-logger */"; 4178 PTDEBUG && _d($sql); 4179 my $text = $src->dbh->selectrow_hashref($sql)->{status}; 4180 ($ts, $fk_error) = get_fk_error($text); 4181 }; 4182 if ( my $e = $EVAL_ERROR ) { 4183 PTDEBUG && _d('Error getting InnoDB status:', $e); 4184 if ( $src->lost_connection($e) ) { 4185 eval { $src->connect() }; 4186 if ( $EVAL_ERROR ) { 4187 warn "Lost connection to MySQL. Will try to reconnect " 4188 . "in the next iteration.\n"; 4189 } 4190 else { 4191 PTDEBUG && _d('Reconnected to MySQL'); 4192 redo ITERATION; 4193 } 4194 } 4195 else { 4196 warn "Error parsing SHOW ENGINE INNODB STATUS: $EVAL_ERROR"; 4197 $exit_status |= 1; 4198 } 4199 } 4200 else { 4201 if ( $ts && $fk_error ) { 4202 # Save and/or print the foreign key error. 4203 if ( $ins_sth ) { 4204 my $fk_ts = parse_timestamp($ts); 4205 PTDEBUG && _d('Saving fk error', $ts, $fk_error); 4206 eval { 4207 $ins_sth->execute($fk_ts, $fk_error); 4208 }; 4209 if ( $EVAL_ERROR ) { 4210 warn $EVAL_ERROR; 4211 PTDEBUG && _d($EVAL_ERROR); 4212 } 4213 } 4214 4215 if ( !$o->get('quiet') ) { 4216 print "$ts $fk_error\n\n"; 4217 } 4218 } 4219 } 4220 4221 # Sleep if there's an --iteration left. 4222 if ( !defined $iters || $iters ) { 4223 PTDEBUG && _d('Sleeping', $interval, 'seconds'); 4224 sleep $interval; 4225 } 4226 } 4227 4228 PTDEBUG && _d('Done running, exiting', $exit_status); 4229 return $exit_status; 4230} 4231 4232# ############################################################################ 4233# Subroutines 4234# ############################################################################ 4235 4236sub get_fk_error { 4237 my ( $text ) = @_; 4238 PTDEBUG && _d($text); 4239 4240 # Quick check if text even has a foreign key error. 4241 if ( $text !~ m/LATEST FOREIGN KEY ERROR/ ) { 4242 PTDEBUG && _d('No fk error'); 4243 return; 4244 } 4245 4246 # InnoDB timestamp 4247 my $idb_ts = qr/((?:\d{6}|\d{4}-\d\d-\d\d) .\d:\d\d:\d\d)/; 4248 4249 my ($ts, $fke) = $text =~ m/LATEST FOREIGN KEY ERROR.+?$idb_ts\s*(.+?)---/ms; 4250 chomp $fke if $fke; 4251 4252 PTDEBUG && _d('Latest fk error:', $ts, $fke); 4253 return $ts, $fke; 4254} 4255 4256sub sig_int { 4257 my ( $signal ) = @_; 4258 $oktorun = 0; 4259 print STDERR "# Caught SIG$signal. Use 'kill -ABRT $PID' if " 4260 . "the tool does not exit normally in a few seconds.\n"; 4261} 4262 4263sub _d { 4264 my ($package, undef, $line) = caller 0; 4265 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 4266 map { defined $_ ? $_ : 'undef' } 4267 @_; 4268 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 4269} 4270 4271# ############################################################################ 4272# Run the program. 4273# ############################################################################ 4274if ( !caller ) { exit main(@ARGV); } 4275 42761; # Because this is a module as well as a script. 4277 4278# ############################################################################ 4279# Documentation 4280# ############################################################################ 4281=pod 4282 4283=head1 NAME 4284 4285pt-fk-error-logger - Log MySQL foreign key errors. 4286 4287=head1 SYNOPSIS 4288 4289Usage: pt-fk-error-logger [OPTIONS] [DSN] 4290 4291pt-fk-error-logger logs information about foreign key errors on the given 4292DSN. Information is printed to C<STDOUT>, and it can also be saved to a 4293table by specifying L<"--dest">. The tool runs for forever unless 4294L<"--run-time"> or L<"--iterations"> is specified. 4295 4296Print foreign key errors on host1: 4297 4298 pt-fk-error-logger h=host1 4299 4300Print foreign key errors on host1 once then exit: 4301 4302 pt-fk-error-logger h=host1 --iterations 1 4303 4304Save foreign key errors on host1 to percona_schema.fke on host2: 4305 4306 pt-fk-error-logger h=host1 --dest h=host2,D=percona_schema,t=fke 4307 4308=head1 RISKS 4309 4310Percona Toolkit is mature, proven in the real world, and well tested, 4311but all database tools can pose a risk to the system and the database 4312server. Before using this tool, please: 4313 4314=over 4315 4316=item * Read the tool's documentation 4317 4318=item * Review the tool's known L<"BUGS"> 4319 4320=item * Test the tool on a non-production server 4321 4322=item * Backup your production server and verify the backups 4323 4324=back 4325 4326=head1 DESCRIPTION 4327 4328pt-fk-error-logger prints or saves the foreign key errors text from 4329C<SHOW INNODB STATUS>. The errors are not parsed or interpreted in any 4330way. Foreign key errors are uniquely identified by their timestamp. 4331Only new (more recent) errors are printed or saved. 4332 4333By default the tool runs forever, checking every L<"--interval"> seconds 4334for new foreign key errors. Specify L<"--run-time"> and/or L<"--iterations"> 4335to limit how long the tool runs. 4336 4337=head1 OUTPUT 4338 4339The foreign key error text from C<SHOW ENGINE INNODB STATUS> is printed 4340to C<STDOUT>, unless L<"--quiet"> is specified. Errors and warnings 4341are printed to C<STDERR>. 4342 4343=head1 OPTIONS 4344 4345This tool accepts additional command-line arguments. Refer to the 4346L<"SYNOPSIS"> and usage information for details. 4347 4348=over 4349 4350=item --ask-pass 4351 4352Prompt for a password when connecting to MySQL. 4353 4354=item --charset 4355 4356short form: -A; type: string 4357 4358Default character set. If the value is utf8, sets Perl's binmode on 4359STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET 4360NAMES UTF8 after connecting to MySQL. Any other value sets binmode on STDOUT 4361without the utf8 layer, and runs SET NAMES after connecting to MySQL. 4362 4363=item --config 4364 4365type: Array 4366 4367Read this comma-separated list of config files; if specified, this must be the 4368first option on the command line. 4369 4370=item --daemonize 4371 4372Fork to the background and detach from the shell. POSIX operating systems only. 4373 4374=item --database 4375 4376short form: -D; type: string 4377 4378Connect to this database. 4379 4380=item --defaults-file 4381 4382short form: -F; type: string 4383 4384Only read mysql options from the given file. You must give an absolute 4385pathname. 4386 4387=item --dest 4388 4389type: DSN 4390 4391Save foreign key errors in this table. The DSN must specify a database (D) 4392and table (t). 4393 4394Missing DSN values are inherited from the DSN being monitored, so you 4395can omit most values if you're saving foreign key errors on the same 4396host. 4397 4398The following table is suggested: 4399 4400 CREATE TABLE foreign_key_errors ( 4401 ts datetime NOT NULL, 4402 error text NOT NULL, 4403 PRIMARY KEY (ts) 4404 ) 4405 4406The only information saved is the timestamp and the foreign key error text. 4407 4408=item --help 4409 4410Show help and exit. 4411 4412=item --host 4413 4414short form: -h; type: string 4415 4416Connect to host. 4417 4418=item --interval 4419 4420type: time; default: 30 4421 4422How often to check for foreign key errors. 4423 4424=item --iterations 4425 4426type: int 4427 4428How many times to check for foreign key errors. By default, this option 4429is undefined which means an infinite number of iterations. The tool always 4430exits for L<"--run-time">, regardless of the value specified for this option. 4431For example, the tool will exit after 1 minute with 4432C<--run-time 1m --iterations 4 --interval 30> because 4 iterations at 30 4433second intervals would take 2 minutes, longer than the 1 mintue run-time. 4434 4435=item --log 4436 4437type: string 4438 4439Print all output to this file when daemonized. 4440 4441=item --password 4442 4443short form: -p; type: string 4444 4445Password to use when connecting. 4446If password contains commas they must be escaped with a backslash: "exam\,ple" 4447 4448=item --pid 4449 4450type: string 4451 4452Create the given PID file. The tool won't start if the PID file already 4453exists and the PID it contains is different than the current PID. However, 4454if the PID file exists and the PID it contains is no longer running, the 4455tool will overwrite the PID file with the current PID. The PID file is 4456removed automatically when the tool exits. 4457 4458=item --port 4459 4460short form: -P; type: int 4461 4462Port number to use for connection. 4463 4464=item --quiet 4465 4466Do not print foreign key errors; only print errors and warnings to C<STDERR>. 4467 4468=item --run-time 4469 4470type: time 4471 4472How long to run before exiting. By default, the tool runs forever. 4473 4474=item --set-vars 4475 4476type: Array 4477 4478Set the MySQL variables in this comma-separated list of C<variable=value> pairs. 4479 4480By default, the tool sets: 4481 4482=for comment ignore-pt-internal-value 4483MAGIC_set_vars 4484 4485 wait_timeout=10000 4486 4487Variables specified on the command line override these defaults. For 4488example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>. 4489 4490The tool prints a warning and continues if a variable cannot be set. 4491 4492=item --socket 4493 4494short form: -S; type: string 4495 4496Socket file to use for connection. 4497 4498=item --user 4499 4500short form: -u; type: string 4501 4502User for login if not current user. 4503 4504=item --version 4505 4506Show version and exit. 4507 4508=item --[no]version-check 4509 4510default: yes 4511 4512Check for the latest version of Percona Toolkit, MySQL, and other programs. 4513 4514This is a standard "check for updates automatically" feature, with two 4515additional features. First, the tool checks its own version and also the 4516versions of the following software: operating system, Percona Monitoring and 4517Management (PMM), MySQL, Perl, MySQL driver for Perl (DBD::mysql), and 4518Percona Toolkit. Second, it checks for and warns about versions with known 4519problems. For example, MySQL 5.5.25 had a critical bug and was re-released 4520as 5.5.25a. 4521 4522A secure connection to Percona’s Version Check database server is done to 4523perform these checks. Each request is logged by the server, including software 4524version numbers and unique ID of the checked system. The ID is generated by the 4525Percona Toolkit installation script or when the Version Check database call is 4526done for the first time. 4527 4528Any updates or known problems are printed to STDOUT before the tool's normal 4529output. This feature should never interfere with the normal operation of the 4530tool. 4531 4532For more information, visit L<https://www.percona.com/doc/percona-toolkit/LATEST/version-check.html>. 4533 4534=back 4535 4536=head1 DSN OPTIONS 4537 4538These DSN options are used to create a DSN. Each option is given like 4539C<option=value>. The options are case-sensitive, so P and p are not the 4540same option. There cannot be whitespace before or after the C<=> and 4541if the value contains whitespace it must be quoted. DSN options are 4542comma-separated. See the L<percona-toolkit> manpage for full details. 4543 4544=over 4545 4546=item * A 4547 4548dsn: charset; copy: yes 4549 4550Default character set. 4551 4552=item * D 4553 4554dsn: database; copy: yes 4555 4556Default database. 4557 4558=item * F 4559 4560dsn: mysql_read_default_file; copy: yes 4561 4562Only read default options from the given file 4563 4564=item * h 4565 4566dsn: host; copy: yes 4567 4568Connect to host. 4569 4570=item * p 4571 4572dsn: password; copy: yes 4573 4574Password to use when connecting. 4575If password contains commas they must be escaped with a backslash: "exam\,ple" 4576 4577=item * P 4578 4579dsn: port; copy: yes 4580 4581Port number to use for connection. 4582 4583=item * S 4584 4585dsn: mysql_socket; copy: yes 4586 4587Socket file to use for connection. 4588 4589=item * t 4590 4591Table in which to store foreign key errors. 4592 4593=item * u 4594 4595dsn: user; copy: yes 4596 4597User for login if not current user. 4598 4599=back 4600 4601=head1 ENVIRONMENT 4602 4603The environment variable C<PTDEBUG> enables verbose debugging output to STDERR. 4604To enable debugging and capture all output to a file, run the tool like: 4605 4606 PTDEBUG=1 pt-fk-error-logger ... > FILE 2>&1 4607 4608Be careful: debugging output is voluminous and can generate several megabytes 4609of output. 4610 4611=head1 SYSTEM REQUIREMENTS 4612 4613You need Perl, DBI, DBD::mysql, and some core packages that ought to be 4614installed in any reasonably new version of Perl. 4615 4616=head1 BUGS 4617 4618For a list of known bugs, see L<http://www.percona.com/bugs/pt-fk-error-logger>. 4619 4620Please report bugs at L<https://jira.percona.com/projects/PT>. 4621Include the following information in your bug report: 4622 4623=over 4624 4625=item * Complete command-line used to run the tool 4626 4627=item * Tool L<"--version"> 4628 4629=item * MySQL version of all servers involved 4630 4631=item * Output from the tool including STDERR 4632 4633=item * Input files (log/dump/config files, etc.) 4634 4635=back 4636 4637If possible, include debugging output by running the tool with C<PTDEBUG>; 4638see L<"ENVIRONMENT">. 4639 4640=head1 DOWNLOADING 4641 4642Visit L<http://www.percona.com/software/percona-toolkit/> to download the 4643latest release of Percona Toolkit. Or, get the latest release from the 4644command line: 4645 4646 wget percona.com/get/percona-toolkit.tar.gz 4647 4648 wget percona.com/get/percona-toolkit.rpm 4649 4650 wget percona.com/get/percona-toolkit.deb 4651 4652You can also get individual tools from the latest release: 4653 4654 wget percona.com/get/TOOL 4655 4656Replace C<TOOL> with the name of any tool. 4657 4658=head1 AUTHORS 4659 4660Daniel Nichter 4661 4662=head1 ABOUT PERCONA TOOLKIT 4663 4664This tool is part of Percona Toolkit, a collection of advanced command-line 4665tools for MySQL developed by Percona. Percona Toolkit was forked from two 4666projects in June, 2011: Maatkit and Aspersa. Those projects were created by 4667Baron Schwartz and primarily developed by him and Daniel Nichter. Visit 4668L<http://www.percona.com/software/> to learn about other free, open-source 4669software from Percona. 4670 4671=head1 COPYRIGHT, LICENSE, AND WARRANTY 4672 4673This program is copyright 2011-2018 Percona LLC and/or its affiliates. 4674 4675THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 4676WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 4677MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 4678 4679This program is free software; you can redistribute it and/or modify it under 4680the terms of the GNU General Public License as published by the Free Software 4681Foundation, version 2; OR the Perl Artistic License. On UNIX and similar 4682systems, you can issue `man perlgpl' or `man perlartistic' to read these 4683licenses. 4684 4685You should have received a copy of the GNU General Public License along with 4686this program; if not, write to the Free Software Foundation, Inc., 59 Temple 4687Place, Suite 330, Boston, MA 02111-1307 USA. 4688 4689=head1 VERSION 4690 4691pt-fk-error-logger 3.3.0 4692 4693=cut 4694