├── .gitignore ├── ChangeLog ├── LICENSE ├── README.md └── pt-slave-restart /.gitignore: -------------------------------------------------------------------------------- 1 | /blib/ 2 | /.build/ 3 | _build/ 4 | cover_db/ 5 | inc/ 6 | Build 7 | !Build/ 8 | Build.bat 9 | .last_cover_stats 10 | /Makefile 11 | /Makefile.old 12 | /MANIFEST.bak 13 | /META.yml 14 | /META.json 15 | /MYMETA.* 16 | nytprof.out 17 | /pm_to_blib 18 | *.o 19 | *.bs 20 | /_eumm/ 21 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | The current pt-slave-restart version is: v0.1 basing on Percona v2.2.15 2 | 3 | Improvements and protocol version compliant new features 4 | are added as following: 5 | 6 | v0.1 BuildTime:2015-10-19 7 | - new pattern 8 | - error_number:1032 9 | error_msg:Could not execute Delete_rows event on table .; Can't find record in '', 10 | Error_code: 1032; handler error HA_ERR_KEY_NOT_FOUND; 11 | 12 | - error_number:1050 13 | error_msg:Error 'Table '.' already exists' on query 14 | 15 | - error_number:1146 16 | error_msg:'Table '.' doesn't exist' on query 17 | 18 | - change action skip 19 | - on RBR or MBR would execute slave_exec_mode=IDEMPOTENT instead of sql_slave_skip_counter 20 | 21 | 22 | - new add function 23 | - function name:get_create_table 24 | - to get table structure 25 | 26 | - Bug Fix 27 | - change slave's binlog_format to master's binlog_format 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 X7 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mysql-slave-self-healing 2 | MySQL Slave故障自愈 3 | 4 | 1、项目背景： 5 | 6 | 1.1、对主备数据一致性要求较高的场景，比如腾讯游戏存储的是玩家数据，备库开放给各种周边系统查询。当slave故障，我们希望备库能够安全地自动修复。 7 | 8 | 1.2、该项目核心修复逻辑是想通过Percona的开源工具：pt-slave-restart来完成，但显然，该工具存在不足。目前只模糊的定义了3种修复模式，分别是SQL语法错误、MyISAM表损坏以及中继日志的损坏，除此之外，其他一切错误都是通过sql_slave_skip_counter来完成，简单且粗暴，对数据的一致性造成成吨伤害。 9 | 10 | 1.3、业界同行对主备故障的修复经验值得积累，如果每个DBA都将这些经验沉淀到这个工具中，前人栽树，后来者只要部署下这个工具即可，把时间用去对业务、对自己更有帮助的事情上，送人玫瑰，手留余香，岂不快哉？ 11 | 12 | 13 | 14 | 15 | 2、怎么参与？ 16 | 17 | 虽然该工具接近6千多行代码，但逻辑比较清晰，只要你是DBA，并且会一点Perl，那么你只需要： 18 | 19 | 2.1、找到数组 @error_patterns，定义你遇到过的case 20 | 21 | 2.2、找到哈希 %actions，写下你的处理经验 22 | 23 | 24 | 希望这是件有意义的事情 ：） 25 | 26 | -------------------------------------------------------------------------------- /pt-slave-restart: -------------------------------------------------------------------------------- 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 | 7 | use strict; 8 | use 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. 14 | BEGIN { 15 | $INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw( 16 | Percona::Toolkit 17 | Quoter 18 | OptionParser 19 | Lmo::Utils 20 | Lmo::Meta 21 | Lmo::Object 22 | Lmo::Types 23 | Lmo 24 | VersionParser 25 | DSNParser 26 | MasterSlave 27 | Daemon 28 | HTTP::Micro 29 | VersionCheck 30 | )); 31 | } 32 | 33 | # ########################################################################### 34 | # Percona::Toolkit package 35 | # This package is a copy without comments from the original. The original 36 | # with comments and its test file can be found in the Bazaar repository at, 37 | # lib/Percona/Toolkit.pm 38 | # t/lib/Percona/Toolkit.t 39 | # See https://launchpad.net/percona-toolkit for more information. 40 | # ########################################################################### 41 | { 42 | package Percona::Toolkit; 43 | 44 | our $VERSION = '2.2.15'; 45 | 46 | use strict; 47 | use warnings FATAL => 'all'; 48 | use English qw(-no_match_vars); 49 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 50 | 51 | use Carp qw(carp cluck); 52 | use Data::Dumper qw(); 53 | 54 | require Exporter; 55 | our @ISA = qw(Exporter); 56 | our @EXPORT_OK = qw( 57 | have_required_args 58 | Dumper 59 | _d 60 | ); 61 | 62 | sub have_required_args { 63 | my ($args, @required_args) = @_; 64 | my $have_required_args = 1; 65 | foreach my $arg ( @required_args ) { 66 | if ( !defined $args->{$arg} ) { 67 | $have_required_args = 0; 68 | carp "Argument $arg is not defined"; 69 | } 70 | } 71 | cluck unless $have_required_args; # print backtrace 72 | return $have_required_args; 73 | } 74 | 75 | sub Dumper { 76 | local $Data::Dumper::Indent = 1; 77 | local $Data::Dumper::Sortkeys = 1; 78 | local $Data::Dumper::Quotekeys = 0; 79 | Data::Dumper::Dumper(@_); 80 | } 81 | 82 | sub _d { 83 | my ($package, undef, $line) = caller 0; 84 | @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 85 | map { defined $_ ? $_ : 'undef' } 86 | @_; 87 | print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 88 | } 89 | 90 | 1; 91 | } 92 | # ########################################################################### 93 | # End Percona::Toolkit package 94 | # ########################################################################### 95 | 96 | # ########################################################################### 97 | # Quoter package 98 | # This package is a copy without comments from the original. The original 99 | # with comments and its test file can be found in the Bazaar repository at, 100 | # lib/Quoter.pm 101 | # t/lib/Quoter.t 102 | # See https://launchpad.net/percona-toolkit for more information. 103 | # ########################################################################### 104 | { 105 | package Quoter; 106 | 107 | use strict; 108 | use warnings FATAL => 'all'; 109 | use English qw(-no_match_vars); 110 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 111 | 112 | use Data::Dumper; 113 | $Data::Dumper::Indent = 1; 114 | $Data::Dumper::Sortkeys = 1; 115 | $Data::Dumper::Quotekeys = 0; 116 | 117 | sub new { 118 | my ( $class, %args ) = @_; 119 | return bless {}, $class; 120 | } 121 | 122 | sub quote { 123 | my ( $self, @vals ) = @_; 124 | foreach my $val ( @vals ) { 125 | $val =~ s/`/``/g; 126 | } 127 | return join('.', map { '`' . $_ . '`' } @vals); 128 | } 129 | 130 | sub quote_val { 131 | my ( $self, $val, %args ) = @_; 132 | 133 | return 'NULL' unless defined $val; # undef = NULL 134 | return "''" if $val eq ''; # blank string = '' 135 | return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data 136 | && !$args{is_char}; # unless is_char is true 137 | 138 | $val =~ s/(['\\])/\\$1/g; 139 | return "'$val'"; 140 | } 141 | 142 | sub split_unquote { 143 | my ( $self, $db_tbl, $default_db ) = @_; 144 | my ( $db, $tbl ) = split(/[.]/, $db_tbl); 145 | if ( !$tbl ) { 146 | $tbl = $db; 147 | $db = $default_db; 148 | } 149 | for ($db, $tbl) { 150 | next unless $_; 151 | s/\A`//; 152 | s/`\z//; 153 | s/``/`/g; 154 | } 155 | 156 | return ($db, $tbl); 157 | } 158 | 159 | sub literal_like { 160 | my ( $self, $like ) = @_; 161 | return unless $like; 162 | $like =~ s/([%_])/\\$1/g; 163 | return "'$like'"; 164 | } 165 | 166 | sub join_quote { 167 | my ( $self, $default_db, $db_tbl ) = @_; 168 | return unless $db_tbl; 169 | my ($db, $tbl) = split(/[.]/, $db_tbl); 170 | if ( !$tbl ) { 171 | $tbl = $db; 172 | $db = $default_db; 173 | } 174 | $db = "`$db`" if $db && $db !~ m/^`/; 175 | $tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/; 176 | return $db ? "$db.$tbl" : $tbl; 177 | } 178 | 179 | sub serialize_list { 180 | my ( $self, @args ) = @_; 181 | PTDEBUG && _d('Serializing', Dumper(\@args)); 182 | return unless @args; 183 | 184 | my @parts; 185 | foreach my $arg ( @args ) { 186 | if ( defined $arg ) { 187 | $arg =~ s/,/\\,/g; # escape commas 188 | $arg =~ s/\\N/\\\\N/g; # escape literal \N 189 | push @parts, $arg; 190 | } 191 | else { 192 | push @parts, '\N'; 193 | } 194 | } 195 | 196 | my $string = join(',', @parts); 197 | PTDEBUG && _d('Serialized: <', $string, '>'); 198 | return $string; 199 | } 200 | 201 | sub deserialize_list { 202 | my ( $self, $string ) = @_; 203 | PTDEBUG && _d('Deserializing <', $string, '>'); 204 | die "Cannot deserialize an undefined string" unless defined $string; 205 | 206 | my @parts; 207 | foreach my $arg ( split(/(? 'all'; 260 | use English qw(-no_match_vars); 261 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 262 | 263 | use List::Util qw(max); 264 | use Getopt::Long; 265 | use Data::Dumper; 266 | 267 | my $POD_link_re = '[LC]<"?([^">]+)"?>'; 268 | 269 | sub new { 270 | my ( $class, %args ) = @_; 271 | my @required_args = qw(); 272 | foreach my $arg ( @required_args ) { 273 | die "I need a $arg argument" unless $args{$arg}; 274 | } 275 | 276 | my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/; 277 | $program_name ||= $PROGRAM_NAME; 278 | my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.'; 279 | 280 | my %attributes = ( 281 | 'type' => 1, 282 | 'short form' => 1, 283 | 'group' => 1, 284 | 'default' => 1, 285 | 'cumulative' => 1, 286 | 'negatable' => 1, 287 | ); 288 | 289 | my $self = { 290 | head1 => 'OPTIONS', # These args are used internally 291 | skip_rules => 0, # to instantiate another Option- 292 | item => '--(.*)', # Parser obj that parses the 293 | attributes => \%attributes, # DSN OPTIONS section. Tools 294 | parse_attributes => \&_parse_attribs, # don't tinker with these args. 295 | 296 | %args, 297 | 298 | strict => 1, # disabled by a special rule 299 | program_name => $program_name, 300 | opts => {}, 301 | got_opts => 0, 302 | short_opts => {}, 303 | defaults => {}, 304 | groups => {}, 305 | allowed_groups => {}, 306 | errors => [], 307 | rules => [], # desc of rules for --help 308 | mutex => [], # rule: opts are mutually exclusive 309 | atleast1 => [], # rule: at least one opt is required 310 | disables => {}, # rule: opt disables other opts 311 | defaults_to => {}, # rule: opt defaults to value of other opt 312 | DSNParser => undef, 313 | default_files => [ 314 | "/etc/percona-toolkit/percona-toolkit.conf", 315 | "/etc/percona-toolkit/$program_name.conf", 316 | "$home/.percona-toolkit.conf", 317 | "$home/.$program_name.conf", 318 | ], 319 | types => { 320 | string => 's', # standard Getopt type 321 | int => 'i', # standard Getopt type 322 | float => 'f', # standard Getopt type 323 | Hash => 'H', # hash, formed from a comma-separated list 324 | hash => 'h', # hash as above, but only if a value is given 325 | Array => 'A', # array, similar to Hash 326 | array => 'a', # array, similar to hash 327 | DSN => 'd', # DSN 328 | size => 'z', # size with kMG suffix (powers of 2^10) 329 | time => 'm', # time, with an optional suffix of s/h/m/d 330 | }, 331 | }; 332 | 333 | return bless $self, $class; 334 | } 335 | 336 | sub get_specs { 337 | my ( $self, $file ) = @_; 338 | $file ||= $self->{file} || __FILE__; 339 | my @specs = $self->_pod_to_specs($file); 340 | $self->_parse_specs(@specs); 341 | 342 | open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 343 | my $contents = do { local $/ = undef; <$fh> }; 344 | close $fh; 345 | if ( $contents =~ m/^=head1 DSN OPTIONS/m ) { 346 | PTDEBUG && _d('Parsing DSN OPTIONS'); 347 | my $dsn_attribs = { 348 | dsn => 1, 349 | copy => 1, 350 | }; 351 | my $parse_dsn_attribs = sub { 352 | my ( $self, $option, $attribs ) = @_; 353 | map { 354 | my $val = $attribs->{$_}; 355 | if ( $val ) { 356 | $val = $val eq 'yes' ? 1 357 | : $val eq 'no' ? 0 358 | : $val; 359 | $attribs->{$_} = $val; 360 | } 361 | } keys %$attribs; 362 | return { 363 | key => $option, 364 | %$attribs, 365 | }; 366 | }; 367 | my $dsn_o = new OptionParser( 368 | description => 'DSN OPTIONS', 369 | head1 => 'DSN OPTIONS', 370 | dsn => 0, # XXX don't infinitely recurse! 371 | item => '\* (.)', # key opts are a single character 372 | skip_rules => 1, # no rules before opts 373 | attributes => $dsn_attribs, 374 | parse_attributes => $parse_dsn_attribs, 375 | ); 376 | my @dsn_opts = map { 377 | my $opts = { 378 | key => $_->{spec}->{key}, 379 | dsn => $_->{spec}->{dsn}, 380 | copy => $_->{spec}->{copy}, 381 | desc => $_->{desc}, 382 | }; 383 | $opts; 384 | } $dsn_o->_pod_to_specs($file); 385 | $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts); 386 | } 387 | 388 | if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) { 389 | $self->{version} = $1; 390 | PTDEBUG && _d($self->{version}); 391 | } 392 | 393 | return; 394 | } 395 | 396 | sub DSNParser { 397 | my ( $self ) = @_; 398 | return $self->{DSNParser}; 399 | }; 400 | 401 | sub get_defaults_files { 402 | my ( $self ) = @_; 403 | return @{$self->{default_files}}; 404 | } 405 | 406 | sub _pod_to_specs { 407 | my ( $self, $file ) = @_; 408 | $file ||= $self->{file} || __FILE__; 409 | open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR"; 410 | 411 | my @specs = (); 412 | my @rules = (); 413 | my $para; 414 | 415 | local $INPUT_RECORD_SEPARATOR = ''; 416 | while ( $para = <$fh> ) { 417 | next unless $para =~ m/^=head1 $self->{head1}/; 418 | last; 419 | } 420 | 421 | while ( $para = <$fh> ) { 422 | last if $para =~ m/^=over/; 423 | next if $self->{skip_rules}; 424 | chomp $para; 425 | $para =~ s/\s+/ /g; 426 | $para =~ s/$POD_link_re/$1/go; 427 | PTDEBUG && _d('Option rule:', $para); 428 | push @rules, $para; 429 | } 430 | 431 | die "POD has no $self->{head1} section" unless $para; 432 | 433 | do { 434 | if ( my ($option) = $para =~ m/^=item $self->{item}/ ) { 435 | chomp $para; 436 | PTDEBUG && _d($para); 437 | my %attribs; 438 | 439 | $para = <$fh>; # read next paragraph, possibly attributes 440 | 441 | if ( $para =~ m/: / ) { # attributes 442 | $para =~ s/\s+\Z//g; 443 | %attribs = map { 444 | my ( $attrib, $val) = split(/: /, $_); 445 | die "Unrecognized attribute for --$option: $attrib" 446 | unless $self->{attributes}->{$attrib}; 447 | ($attrib, $val); 448 | } split(/; /, $para); 449 | if ( $attribs{'short form'} ) { 450 | $attribs{'short form'} =~ s/-//; 451 | } 452 | $para = <$fh>; # read next paragraph, probably short help desc 453 | } 454 | else { 455 | PTDEBUG && _d('Option has no attributes'); 456 | } 457 | 458 | $para =~ s/\s+\Z//g; 459 | $para =~ s/\s+/ /g; 460 | $para =~ s/$POD_link_re/$1/go; 461 | 462 | $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s; 463 | PTDEBUG && _d('Short help:', $para); 464 | 465 | die "No description after option spec $option" if $para =~ m/^=item/; 466 | 467 | if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) { 468 | $option = $base_option; 469 | $attribs{'negatable'} = 1; 470 | } 471 | 472 | push @specs, { 473 | spec => $self->{parse_attributes}->($self, $option, \%attribs), 474 | desc => $para 475 | . (defined $attribs{default} ? " (default $attribs{default})" : ''), 476 | group => ($attribs{'group'} ? $attribs{'group'} : 'default'), 477 | }; 478 | } 479 | while ( $para = <$fh> ) { 480 | last unless $para; 481 | if ( $para =~ m/^=head1/ ) { 482 | $para = undef; # Can't 'last' out of a do {} block. 483 | last; 484 | } 485 | last if $para =~ m/^=item /; 486 | } 487 | } while ( $para ); 488 | 489 | die "No valid specs in $self->{head1}" unless @specs; 490 | 491 | close $fh; 492 | return @specs, @rules; 493 | } 494 | 495 | sub _parse_specs { 496 | my ( $self, @specs ) = @_; 497 | my %disables; # special rule that requires deferred checking 498 | 499 | foreach my $opt ( @specs ) { 500 | if ( ref $opt ) { # It's an option spec, not a rule. 501 | PTDEBUG && _d('Parsing opt spec:', 502 | map { ($_, '=>', $opt->{$_}) } keys %$opt); 503 | 504 | my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/; 505 | if ( !$long ) { 506 | die "Cannot parse long option from spec $opt->{spec}"; 507 | } 508 | $opt->{long} = $long; 509 | 510 | die "Duplicate long option --$long" if exists $self->{opts}->{$long}; 511 | $self->{opts}->{$long} = $opt; 512 | 513 | if ( length $long == 1 ) { 514 | PTDEBUG && _d('Long opt', $long, 'looks like short opt'); 515 | $self->{short_opts}->{$long} = $long; 516 | } 517 | 518 | if ( $short ) { 519 | die "Duplicate short option -$short" 520 | if exists $self->{short_opts}->{$short}; 521 | $self->{short_opts}->{$short} = $long; 522 | $opt->{short} = $short; 523 | } 524 | else { 525 | $opt->{short} = undef; 526 | } 527 | 528 | $opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0; 529 | $opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0; 530 | $opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0; 531 | 532 | $opt->{group} ||= 'default'; 533 | $self->{groups}->{ $opt->{group} }->{$long} = 1; 534 | 535 | $opt->{value} = undef; 536 | $opt->{got} = 0; 537 | 538 | my ( $type ) = $opt->{spec} =~ m/=(.)/; 539 | $opt->{type} = $type; 540 | PTDEBUG && _d($long, 'type:', $type); 541 | 542 | 543 | $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ ); 544 | 545 | if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) { 546 | $self->{defaults}->{$long} = defined $def ? $def : 1; 547 | PTDEBUG && _d($long, 'default:', $def); 548 | } 549 | 550 | if ( $long eq 'config' ) { 551 | $self->{defaults}->{$long} = join(',', $self->get_defaults_files()); 552 | } 553 | 554 | if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) { 555 | $disables{$long} = $dis; 556 | PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis); 557 | } 558 | 559 | $self->{opts}->{$long} = $opt; 560 | } 561 | else { # It's an option rule, not a spec. 562 | PTDEBUG && _d('Parsing rule:', $opt); 563 | push @{$self->{rules}}, $opt; 564 | my @participants = $self->_get_participants($opt); 565 | my $rule_ok = 0; 566 | 567 | if ( $opt =~ m/mutually exclusive|one and only one/ ) { 568 | $rule_ok = 1; 569 | push @{$self->{mutex}}, \@participants; 570 | PTDEBUG && _d(@participants, 'are mutually exclusive'); 571 | } 572 | if ( $opt =~ m/at least one|one and only one/ ) { 573 | $rule_ok = 1; 574 | push @{$self->{atleast1}}, \@participants; 575 | PTDEBUG && _d(@participants, 'require at least one'); 576 | } 577 | if ( $opt =~ m/default to/ ) { 578 | $rule_ok = 1; 579 | $self->{defaults_to}->{$participants[0]} = $participants[1]; 580 | PTDEBUG && _d($participants[0], 'defaults to', $participants[1]); 581 | } 582 | if ( $opt =~ m/restricted to option groups/ ) { 583 | $rule_ok = 1; 584 | my ($groups) = $opt =~ m/groups ([\w\s\,]+)/; 585 | my @groups = split(',', $groups); 586 | %{$self->{allowed_groups}->{$participants[0]}} = map { 587 | s/\s+//; 588 | $_ => 1; 589 | } @groups; 590 | } 591 | if( $opt =~ m/accepts additional command-line arguments/ ) { 592 | $rule_ok = 1; 593 | $self->{strict} = 0; 594 | PTDEBUG && _d("Strict mode disabled by rule"); 595 | } 596 | 597 | die "Unrecognized option rule: $opt" unless $rule_ok; 598 | } 599 | } 600 | 601 | foreach my $long ( keys %disables ) { 602 | my @participants = $self->_get_participants($disables{$long}); 603 | $self->{disables}->{$long} = \@participants; 604 | PTDEBUG && _d('Option', $long, 'disables', @participants); 605 | } 606 | 607 | return; 608 | } 609 | 610 | sub _get_participants { 611 | my ( $self, $str ) = @_; 612 | my @participants; 613 | foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) { 614 | die "Option --$long does not exist while processing rule $str" 615 | unless exists $self->{opts}->{$long}; 616 | push @participants, $long; 617 | } 618 | PTDEBUG && _d('Participants for', $str, ':', @participants); 619 | return @participants; 620 | } 621 | 622 | sub opts { 623 | my ( $self ) = @_; 624 | my %opts = %{$self->{opts}}; 625 | return %opts; 626 | } 627 | 628 | sub short_opts { 629 | my ( $self ) = @_; 630 | my %short_opts = %{$self->{short_opts}}; 631 | return %short_opts; 632 | } 633 | 634 | sub set_defaults { 635 | my ( $self, %defaults ) = @_; 636 | $self->{defaults} = {}; 637 | foreach my $long ( keys %defaults ) { 638 | die "Cannot set default for nonexistent option $long" 639 | unless exists $self->{opts}->{$long}; 640 | $self->{defaults}->{$long} = $defaults{$long}; 641 | PTDEBUG && _d('Default val for', $long, ':', $defaults{$long}); 642 | } 643 | return; 644 | } 645 | 646 | sub get_defaults { 647 | my ( $self ) = @_; 648 | return $self->{defaults}; 649 | } 650 | 651 | sub get_groups { 652 | my ( $self ) = @_; 653 | return $self->{groups}; 654 | } 655 | 656 | sub _set_option { 657 | my ( $self, $opt, $val ) = @_; 658 | my $long = exists $self->{opts}->{$opt} ? $opt 659 | : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt} 660 | : die "Getopt::Long gave a nonexistent option: $opt"; 661 | $opt = $self->{opts}->{$long}; 662 | if ( $opt->{is_cumulative} ) { 663 | $opt->{value}++; 664 | } 665 | elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) { 666 | my $next_opt = $1; 667 | if ( exists $self->{opts}->{$next_opt} 668 | || exists $self->{short_opts}->{$next_opt} ) { 669 | $self->save_error("--$long requires a string value"); 670 | return; 671 | } 672 | else { 673 | $opt->{value} = $val; 674 | } 675 | } 676 | else { 677 | $opt->{value} = $val; 678 | } 679 | $opt->{got} = 1; 680 | PTDEBUG && _d('Got option', $long, '=', $val); 681 | } 682 | 683 | sub get_opts { 684 | my ( $self ) = @_; 685 | 686 | foreach my $long ( keys %{$self->{opts}} ) { 687 | $self->{opts}->{$long}->{got} = 0; 688 | $self->{opts}->{$long}->{value} 689 | = exists $self->{defaults}->{$long} ? $self->{defaults}->{$long} 690 | : $self->{opts}->{$long}->{is_cumulative} ? 0 691 | : undef; 692 | } 693 | $self->{got_opts} = 0; 694 | 695 | $self->{errors} = []; 696 | 697 | if ( @ARGV && $ARGV[0] eq "--config" ) { 698 | shift @ARGV; 699 | $self->_set_option('config', shift @ARGV); 700 | } 701 | if ( $self->has('config') ) { 702 | my @extra_args; 703 | foreach my $filename ( split(',', $self->get('config')) ) { 704 | eval { 705 | push @extra_args, $self->_read_config_file($filename); 706 | }; 707 | if ( $EVAL_ERROR ) { 708 | if ( $self->got('config') ) { 709 | die $EVAL_ERROR; 710 | } 711 | elsif ( PTDEBUG ) { 712 | _d($EVAL_ERROR); 713 | } 714 | } 715 | } 716 | unshift @ARGV, @extra_args; 717 | } 718 | 719 | Getopt::Long::Configure('no_ignore_case', 'bundling'); 720 | GetOptions( 721 | map { $_->{spec} => sub { $self->_set_option(@_); } } 722 | grep { $_->{long} ne 'config' } # --config is handled specially above. 723 | values %{$self->{opts}} 724 | ) or $self->save_error('Error parsing options'); 725 | 726 | if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) { 727 | if ( $self->{version} ) { 728 | print $self->{version}, "\n"; 729 | } 730 | else { 731 | print "Error parsing version. See the VERSION section of the tool's documentation.\n"; 732 | } 733 | exit 1; 734 | } 735 | 736 | if ( @ARGV && $self->{strict} ) { 737 | $self->save_error("Unrecognized command-line options @ARGV"); 738 | } 739 | 740 | foreach my $mutex ( @{$self->{mutex}} ) { 741 | my @set = grep { $self->{opts}->{$_}->{got} } @$mutex; 742 | if ( @set > 1 ) { 743 | my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } 744 | @{$mutex}[ 0 .. scalar(@$mutex) - 2] ) 745 | . ' and --'.$self->{opts}->{$mutex->[-1]}->{long} 746 | . ' are mutually exclusive.'; 747 | $self->save_error($err); 748 | } 749 | } 750 | 751 | foreach my $required ( @{$self->{atleast1}} ) { 752 | my @set = grep { $self->{opts}->{$_}->{got} } @$required; 753 | if ( @set == 0 ) { 754 | my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } 755 | @{$required}[ 0 .. scalar(@$required) - 2] ) 756 | .' or --'.$self->{opts}->{$required->[-1]}->{long}; 757 | $self->save_error("Specify at least one of $err"); 758 | } 759 | } 760 | 761 | $self->_check_opts( keys %{$self->{opts}} ); 762 | $self->{got_opts} = 1; 763 | return; 764 | } 765 | 766 | sub _check_opts { 767 | my ( $self, @long ) = @_; 768 | my $long_last = scalar @long; 769 | while ( @long ) { 770 | foreach my $i ( 0..$#long ) { 771 | my $long = $long[$i]; 772 | next unless $long; 773 | my $opt = $self->{opts}->{$long}; 774 | if ( $opt->{got} ) { 775 | if ( exists $self->{disables}->{$long} ) { 776 | my @disable_opts = @{$self->{disables}->{$long}}; 777 | map { $self->{opts}->{$_}->{value} = undef; } @disable_opts; 778 | PTDEBUG && _d('Unset options', @disable_opts, 779 | 'because', $long,'disables them'); 780 | } 781 | 782 | if ( exists $self->{allowed_groups}->{$long} ) { 783 | 784 | my @restricted_groups = grep { 785 | !exists $self->{allowed_groups}->{$long}->{$_} 786 | } keys %{$self->{groups}}; 787 | 788 | my @restricted_opts; 789 | foreach my $restricted_group ( @restricted_groups ) { 790 | RESTRICTED_OPT: 791 | foreach my $restricted_opt ( 792 | keys %{$self->{groups}->{$restricted_group}} ) 793 | { 794 | next RESTRICTED_OPT if $restricted_opt eq $long; 795 | push @restricted_opts, $restricted_opt 796 | if $self->{opts}->{$restricted_opt}->{got}; 797 | } 798 | } 799 | 800 | if ( @restricted_opts ) { 801 | my $err; 802 | if ( @restricted_opts == 1 ) { 803 | $err = "--$restricted_opts[0]"; 804 | } 805 | else { 806 | $err = join(', ', 807 | map { "--$self->{opts}->{$_}->{long}" } 808 | grep { $_ } 809 | @restricted_opts[0..scalar(@restricted_opts) - 2] 810 | ) 811 | . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long}; 812 | } 813 | $self->save_error("--$long is not allowed with $err"); 814 | } 815 | } 816 | 817 | } 818 | elsif ( $opt->{is_required} ) { 819 | $self->save_error("Required option --$long must be specified"); 820 | } 821 | 822 | $self->_validate_type($opt); 823 | if ( $opt->{parsed} ) { 824 | delete $long[$i]; 825 | } 826 | else { 827 | PTDEBUG && _d('Temporarily failed to parse', $long); 828 | } 829 | } 830 | 831 | die "Failed to parse options, possibly due to circular dependencies" 832 | if @long == $long_last; 833 | $long_last = @long; 834 | } 835 | 836 | return; 837 | } 838 | 839 | sub _validate_type { 840 | my ( $self, $opt ) = @_; 841 | return unless $opt; 842 | 843 | if ( !$opt->{type} ) { 844 | $opt->{parsed} = 1; 845 | return; 846 | } 847 | 848 | my $val = $opt->{value}; 849 | 850 | if ( $val && $opt->{type} eq 'm' ) { # type time 851 | PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value'); 852 | my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/; 853 | if ( !$suffix ) { 854 | my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/; 855 | $suffix = $s || 's'; 856 | PTDEBUG && _d('No suffix given; using', $suffix, 'for', 857 | $opt->{long}, '(value:', $val, ')'); 858 | } 859 | if ( $suffix =~ m/[smhd]/ ) { 860 | $val = $suffix eq 's' ? $num # Seconds 861 | : $suffix eq 'm' ? $num * 60 # Minutes 862 | : $suffix eq 'h' ? $num * 3600 # Hours 863 | : $num * 86400; # Days 864 | $opt->{value} = ($prefix || '') . $val; 865 | PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val); 866 | } 867 | else { 868 | $self->save_error("Invalid time suffix for --$opt->{long}"); 869 | } 870 | } 871 | elsif ( $val && $opt->{type} eq 'd' ) { # type DSN 872 | PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN'); 873 | my $prev = {}; 874 | my $from_key = $self->{defaults_to}->{ $opt->{long} }; 875 | if ( $from_key ) { 876 | PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN'); 877 | if ( $self->{opts}->{$from_key}->{parsed} ) { 878 | $prev = $self->{opts}->{$from_key}->{value}; 879 | } 880 | else { 881 | PTDEBUG && _d('Cannot parse', $opt->{long}, 'until', 882 | $from_key, 'parsed'); 883 | return; 884 | } 885 | } 886 | my $defaults = $self->{DSNParser}->parse_options($self); 887 | $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults); 888 | } 889 | elsif ( $val && $opt->{type} eq 'z' ) { # type size 890 | PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value'); 891 | $self->_parse_size($opt, $val); 892 | } 893 | elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) { 894 | $opt->{value} = { map { $_ => 1 } split(/(?{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) { 897 | $opt->{value} = [ split(/(?{long}, 'type', $opt->{type}, 'value', $val); 902 | } 903 | 904 | $opt->{parsed} = 1; 905 | return; 906 | } 907 | 908 | sub get { 909 | my ( $self, $opt ) = @_; 910 | my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 911 | die "Option $opt does not exist" 912 | unless $long && exists $self->{opts}->{$long}; 913 | return $self->{opts}->{$long}->{value}; 914 | } 915 | 916 | sub got { 917 | my ( $self, $opt ) = @_; 918 | my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 919 | die "Option $opt does not exist" 920 | unless $long && exists $self->{opts}->{$long}; 921 | return $self->{opts}->{$long}->{got}; 922 | } 923 | 924 | sub has { 925 | my ( $self, $opt ) = @_; 926 | my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 927 | return defined $long ? exists $self->{opts}->{$long} : 0; 928 | } 929 | 930 | sub set { 931 | my ( $self, $opt, $val ) = @_; 932 | my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 933 | die "Option $opt does not exist" 934 | unless $long && exists $self->{opts}->{$long}; 935 | $self->{opts}->{$long}->{value} = $val; 936 | return; 937 | } 938 | 939 | sub save_error { 940 | my ( $self, $error ) = @_; 941 | push @{$self->{errors}}, $error; 942 | return; 943 | } 944 | 945 | sub errors { 946 | my ( $self ) = @_; 947 | return $self->{errors}; 948 | } 949 | 950 | sub usage { 951 | my ( $self ) = @_; 952 | warn "No usage string is set" unless $self->{usage}; # XXX 953 | return "Usage: " . ($self->{usage} || '') . "\n"; 954 | } 955 | 956 | sub descr { 957 | my ( $self ) = @_; 958 | warn "No description string is set" unless $self->{description}; # XXX 959 | my $descr = ($self->{description} || $self->{program_name} || '') 960 | . " For more details, please use the --help option, " 961 | . "or try 'perldoc $PROGRAM_NAME' " 962 | . "for complete documentation."; 963 | $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g) 964 | unless $ENV{DONT_BREAK_LINES}; 965 | $descr =~ s/ +$//mg; 966 | return $descr; 967 | } 968 | 969 | sub usage_or_errors { 970 | my ( $self, $file, $return ) = @_; 971 | $file ||= $self->{file} || __FILE__; 972 | 973 | if ( !$self->{description} || !$self->{usage} ) { 974 | PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file); 975 | my %synop = $self->_parse_synopsis($file); 976 | $self->{description} ||= $synop{description}; 977 | $self->{usage} ||= $synop{usage}; 978 | PTDEBUG && _d("Description:", $self->{description}, 979 | "\nUsage:", $self->{usage}); 980 | } 981 | 982 | if ( $self->{opts}->{help}->{got} ) { 983 | print $self->print_usage() or die "Cannot print usage: $OS_ERROR"; 984 | exit 0 unless $return; 985 | } 986 | elsif ( scalar @{$self->{errors}} ) { 987 | print $self->print_errors() or die "Cannot print errors: $OS_ERROR"; 988 | exit 1 unless $return; 989 | } 990 | 991 | return; 992 | } 993 | 994 | sub print_errors { 995 | my ( $self ) = @_; 996 | my $usage = $self->usage() . "\n"; 997 | if ( (my @errors = @{$self->{errors}}) ) { 998 | $usage .= join("\n * ", 'Errors in command-line arguments:', @errors) 999 | . "\n"; 1000 | } 1001 | return $usage . "\n" . $self->descr(); 1002 | } 1003 | 1004 | sub print_usage { 1005 | my ( $self ) = @_; 1006 | die "Run get_opts() before print_usage()" unless $self->{got_opts}; 1007 | my @opts = values %{$self->{opts}}; 1008 | 1009 | my $maxl = max( 1010 | map { 1011 | length($_->{long}) # option long name 1012 | + ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable 1013 | + ($_->{type} ? 2 : 0) # "=x" where x is the opt type 1014 | } 1015 | @opts); 1016 | 1017 | my $maxs = max(0, 1018 | map { 1019 | length($_) 1020 | + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0) 1021 | + ($self->{opts}->{$_}->{type} ? 2 : 0) 1022 | } 1023 | values %{$self->{short_opts}}); 1024 | 1025 | my $lcol = max($maxl, ($maxs + 3)); 1026 | my $rcol = 80 - $lcol - 6; 1027 | my $rpad = ' ' x ( 80 - $rcol ); 1028 | 1029 | $maxs = max($lcol - 3, $maxs); 1030 | 1031 | my $usage = $self->descr() . "\n" . $self->usage(); 1032 | 1033 | my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}}; 1034 | push @groups, 'default'; 1035 | 1036 | foreach my $group ( reverse @groups ) { 1037 | $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n"; 1038 | foreach my $opt ( 1039 | sort { $a->{long} cmp $b->{long} } 1040 | grep { $_->{group} eq $group } 1041 | @opts ) 1042 | { 1043 | my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long}; 1044 | my $short = $opt->{short}; 1045 | my $desc = $opt->{desc}; 1046 | 1047 | $long .= $opt->{type} ? "=$opt->{type}" : ""; 1048 | 1049 | if ( $opt->{type} && $opt->{type} eq 'm' ) { 1050 | my ($s) = $desc =~ m/\(suffix (.)\)/; 1051 | $s ||= 's'; 1052 | $desc =~ s/\s+\(suffix .\)//; 1053 | $desc .= ". Optional suffix s=seconds, m=minutes, h=hours, " 1054 | . "d=days; if no suffix, $s is used."; 1055 | } 1056 | $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g); 1057 | $desc =~ s/ +$//mg; 1058 | if ( $short ) { 1059 | $usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc); 1060 | } 1061 | else { 1062 | $usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc); 1063 | } 1064 | } 1065 | } 1066 | 1067 | $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n"; 1068 | 1069 | if ( (my @rules = @{$self->{rules}}) ) { 1070 | $usage .= "\nRules:\n\n"; 1071 | $usage .= join("\n", map { " $_" } @rules) . "\n"; 1072 | } 1073 | if ( $self->{DSNParser} ) { 1074 | $usage .= "\n" . $self->{DSNParser}->usage(); 1075 | } 1076 | $usage .= "\nOptions and values after processing arguments:\n\n"; 1077 | foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) { 1078 | my $val = $opt->{value}; 1079 | my $type = $opt->{type} || ''; 1080 | my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/; 1081 | $val = $bool ? ( $val ? 'TRUE' : 'FALSE' ) 1082 | : !defined $val ? '(No value)' 1083 | : $type eq 'd' ? $self->{DSNParser}->as_string($val) 1084 | : $type =~ m/H|h/ ? join(',', sort keys %$val) 1085 | : $type =~ m/A|a/ ? join(',', @$val) 1086 | : $val; 1087 | $usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val); 1088 | } 1089 | return $usage; 1090 | } 1091 | 1092 | sub prompt_noecho { 1093 | shift @_ if ref $_[0] eq __PACKAGE__; 1094 | my ( $prompt ) = @_; 1095 | local $OUTPUT_AUTOFLUSH = 1; 1096 | print STDERR $prompt 1097 | or die "Cannot print: $OS_ERROR"; 1098 | my $response; 1099 | eval { 1100 | require Term::ReadKey; 1101 | Term::ReadKey::ReadMode('noecho'); 1102 | chomp($response = ); 1103 | Term::ReadKey::ReadMode('normal'); 1104 | print "\n" 1105 | or die "Cannot print: $OS_ERROR"; 1106 | }; 1107 | if ( $EVAL_ERROR ) { 1108 | die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR"; 1109 | } 1110 | return $response; 1111 | } 1112 | 1113 | sub _read_config_file { 1114 | my ( $self, $filename ) = @_; 1115 | open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n"; 1116 | my @args; 1117 | my $prefix = '--'; 1118 | my $parse = 1; 1119 | 1120 | LINE: 1121 | while ( my $line = <$fh> ) { 1122 | chomp $line; 1123 | next LINE if $line =~ m/^\s*(?:\#|\;|$)/; 1124 | $line =~ s/\s+#.*$//g; 1125 | $line =~ s/^\s+|\s+$//g; 1126 | if ( $line eq '--' ) { 1127 | $prefix = ''; 1128 | $parse = 0; 1129 | next LINE; 1130 | } 1131 | if ( $parse 1132 | && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/) 1133 | ) { 1134 | push @args, grep { defined $_ } ("$prefix$opt", $arg); 1135 | } 1136 | elsif ( $line =~ m/./ ) { 1137 | push @args, $line; 1138 | } 1139 | else { 1140 | die "Syntax error in file $filename at line $INPUT_LINE_NUMBER"; 1141 | } 1142 | } 1143 | close $fh; 1144 | return @args; 1145 | } 1146 | 1147 | sub read_para_after { 1148 | my ( $self, $file, $regex ) = @_; 1149 | open my $fh, "<", $file or die "Can't open $file: $OS_ERROR"; 1150 | local $INPUT_RECORD_SEPARATOR = ''; 1151 | my $para; 1152 | while ( $para = <$fh> ) { 1153 | next unless $para =~ m/^=pod$/m; 1154 | last; 1155 | } 1156 | while ( $para = <$fh> ) { 1157 | next unless $para =~ m/$regex/; 1158 | last; 1159 | } 1160 | $para = <$fh>; 1161 | chomp($para); 1162 | close $fh or die "Can't close $file: $OS_ERROR"; 1163 | return $para; 1164 | } 1165 | 1166 | sub clone { 1167 | my ( $self ) = @_; 1168 | 1169 | my %clone = map { 1170 | my $hashref = $self->{$_}; 1171 | my $val_copy = {}; 1172 | foreach my $key ( keys %$hashref ) { 1173 | my $ref = ref $hashref->{$key}; 1174 | $val_copy->{$key} = !$ref ? $hashref->{$key} 1175 | : $ref eq 'HASH' ? { %{$hashref->{$key}} } 1176 | : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ] 1177 | : $hashref->{$key}; 1178 | } 1179 | $_ => $val_copy; 1180 | } qw(opts short_opts defaults); 1181 | 1182 | foreach my $scalar ( qw(got_opts) ) { 1183 | $clone{$scalar} = $self->{$scalar}; 1184 | } 1185 | 1186 | return bless \%clone; 1187 | } 1188 | 1189 | sub _parse_size { 1190 | my ( $self, $opt, $val ) = @_; 1191 | 1192 | if ( lc($val || '') eq 'null' ) { 1193 | PTDEBUG && _d('NULL size for', $opt->{long}); 1194 | $opt->{value} = 'null'; 1195 | return; 1196 | } 1197 | 1198 | my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824); 1199 | my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/; 1200 | if ( defined $num ) { 1201 | if ( $factor ) { 1202 | $num *= $factor_for{$factor}; 1203 | PTDEBUG && _d('Setting option', $opt->{y}, 1204 | 'to num', $num, '* factor', $factor); 1205 | } 1206 | $opt->{value} = ($pre || '') . $num; 1207 | } 1208 | else { 1209 | $self->save_error("Invalid size for --$opt->{long}: $val"); 1210 | } 1211 | return; 1212 | } 1213 | 1214 | sub _parse_attribs { 1215 | my ( $self, $option, $attribs ) = @_; 1216 | my $types = $self->{types}; 1217 | return $option 1218 | . ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' ) 1219 | . ($attribs->{'negatable'} ? '!' : '' ) 1220 | . ($attribs->{'cumulative'} ? '+' : '' ) 1221 | . ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' ); 1222 | } 1223 | 1224 | sub _parse_synopsis { 1225 | my ( $self, $file ) = @_; 1226 | $file ||= $self->{file} || __FILE__; 1227 | PTDEBUG && _d("Parsing SYNOPSIS in", $file); 1228 | 1229 | local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs 1230 | open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 1231 | my $para; 1232 | 1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/; 1233 | die "$file does not contain a SYNOPSIS section" unless $para; 1234 | my @synop; 1235 | for ( 1..2 ) { # 1 for the usage, 2 for the description 1236 | my $para = <$fh>; 1237 | push @synop, $para; 1238 | } 1239 | close $fh; 1240 | PTDEBUG && _d("Raw SYNOPSIS text:", @synop); 1241 | my ($usage, $desc) = @synop; 1242 | die "The SYNOPSIS section in $file is not formatted properly" 1243 | unless $usage && $desc; 1244 | 1245 | $usage =~ s/^\s*Usage:\s+(.+)/$1/; 1246 | chomp $usage; 1247 | 1248 | $desc =~ s/\n/ /g; 1249 | $desc =~ s/\s{2,}/ /g; 1250 | $desc =~ s/\. ([A-Z][a-z])/. $1/g; 1251 | $desc =~ s/\s+$//; 1252 | 1253 | return ( 1254 | description => $desc, 1255 | usage => $usage, 1256 | ); 1257 | }; 1258 | 1259 | sub set_vars { 1260 | my ($self, $file) = @_; 1261 | $file ||= $self->{file} || __FILE__; 1262 | 1263 | my %user_vars; 1264 | my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef; 1265 | if ( $user_vars ) { 1266 | foreach my $var_val ( @$user_vars ) { 1267 | my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; 1268 | die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; 1269 | $user_vars{$var} = { 1270 | val => $val, 1271 | default => 0, 1272 | }; 1273 | } 1274 | } 1275 | 1276 | my %default_vars; 1277 | my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/); 1278 | if ( $default_vars ) { 1279 | %default_vars = map { 1280 | my $var_val = $_; 1281 | my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; 1282 | die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; 1283 | $var => { 1284 | val => $val, 1285 | default => 1, 1286 | }; 1287 | } split("\n", $default_vars); 1288 | } 1289 | 1290 | my %vars = ( 1291 | %default_vars, # first the tool's defaults 1292 | %user_vars, # then the user's which overwrite the defaults 1293 | ); 1294 | PTDEBUG && _d('--set-vars:', Dumper(\%vars)); 1295 | return \%vars; 1296 | } 1297 | 1298 | sub _d { 1299 | my ($package, undef, $line) = caller 0; 1300 | @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 1301 | map { defined $_ ? $_ : 'undef' } 1302 | @_; 1303 | print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 1304 | } 1305 | 1306 | if ( PTDEBUG ) { 1307 | print STDERR '# ', $^X, ' ', $], "\n"; 1308 | if ( my $uname = `uname -a` ) { 1309 | $uname =~ s/\s+/ /g; 1310 | print STDERR "# $uname\n"; 1311 | } 1312 | print STDERR '# Arguments: ', 1313 | join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n"; 1314 | } 1315 | 1316 | 1; 1317 | } 1318 | # ########################################################################### 1319 | # End OptionParser package 1320 | # ########################################################################### 1321 | 1322 | # ########################################################################### 1323 | # Lmo::Utils package 1324 | # This package is a copy without comments from the original. The original 1325 | # with comments and its test file can be found in the Bazaar repository at, 1326 | # lib/Lmo/Utils.pm 1327 | # t/lib/Lmo/Utils.t 1328 | # See https://launchpad.net/percona-toolkit for more information. 1329 | # ########################################################################### 1330 | { 1331 | package Lmo::Utils; 1332 | 1333 | use strict; 1334 | use warnings qw( FATAL all ); 1335 | require Exporter; 1336 | our (@ISA, @EXPORT, @EXPORT_OK); 1337 | 1338 | BEGIN { 1339 | @ISA = qw(Exporter); 1340 | @EXPORT = @EXPORT_OK = qw( 1341 | _install_coderef 1342 | _unimport_coderefs 1343 | _glob_for 1344 | _stash_for 1345 | ); 1346 | } 1347 | 1348 | { 1349 | no strict 'refs'; 1350 | sub _glob_for { 1351 | return \*{shift()} 1352 | } 1353 | 1354 | sub _stash_for { 1355 | return \%{ shift() . "::" }; 1356 | } 1357 | } 1358 | 1359 | sub _install_coderef { 1360 | my ($to, $code) = @_; 1361 | 1362 | return *{ _glob_for $to } = $code; 1363 | } 1364 | 1365 | sub _unimport_coderefs { 1366 | my ($target, @names) = @_; 1367 | return unless @names; 1368 | my $stash = _stash_for($target); 1369 | foreach my $name (@names) { 1370 | if ($stash->{$name} and defined(&{$stash->{$name}})) { 1371 | delete $stash->{$name}; 1372 | } 1373 | } 1374 | } 1375 | 1376 | 1; 1377 | } 1378 | # ########################################################################### 1379 | # End Lmo::Utils package 1380 | # ########################################################################### 1381 | 1382 | # ########################################################################### 1383 | # Lmo::Meta package 1384 | # This package is a copy without comments from the original. The original 1385 | # with comments and its test file can be found in the Bazaar repository at, 1386 | # lib/Lmo/Meta.pm 1387 | # t/lib/Lmo/Meta.t 1388 | # See https://launchpad.net/percona-toolkit for more information. 1389 | # ########################################################################### 1390 | { 1391 | package Lmo::Meta; 1392 | use strict; 1393 | use warnings qw( FATAL all ); 1394 | 1395 | my %metadata_for; 1396 | 1397 | sub new { 1398 | my $class = shift; 1399 | return bless { @_ }, $class 1400 | } 1401 | 1402 | sub metadata_for { 1403 | my $self = shift; 1404 | my ($class) = @_; 1405 | 1406 | return $metadata_for{$class} ||= {}; 1407 | } 1408 | 1409 | sub class { shift->{class} } 1410 | 1411 | sub attributes { 1412 | my $self = shift; 1413 | return keys %{$self->metadata_for($self->class)} 1414 | } 1415 | 1416 | sub attributes_for_new { 1417 | my $self = shift; 1418 | my @attributes; 1419 | 1420 | my $class_metadata = $self->metadata_for($self->class); 1421 | while ( my ($attr, $meta) = each %$class_metadata ) { 1422 | if ( exists $meta->{init_arg} ) { 1423 | push @attributes, $meta->{init_arg} 1424 | if defined $meta->{init_arg}; 1425 | } 1426 | else { 1427 | push @attributes, $attr; 1428 | } 1429 | } 1430 | return @attributes; 1431 | } 1432 | 1433 | 1; 1434 | } 1435 | # ########################################################################### 1436 | # End Lmo::Meta package 1437 | # ########################################################################### 1438 | 1439 | # ########################################################################### 1440 | # Lmo::Object package 1441 | # This package is a copy without comments from the original. The original 1442 | # with comments and its test file can be found in the Bazaar repository at, 1443 | # lib/Lmo/Object.pm 1444 | # t/lib/Lmo/Object.t 1445 | # See https://launchpad.net/percona-toolkit for more information. 1446 | # ########################################################################### 1447 | { 1448 | package Lmo::Object; 1449 | 1450 | use strict; 1451 | use warnings qw( FATAL all ); 1452 | 1453 | use Carp (); 1454 | use Scalar::Util qw(blessed); 1455 | 1456 | use Lmo::Meta; 1457 | use Lmo::Utils qw(_glob_for); 1458 | 1459 | sub new { 1460 | my $class = shift; 1461 | my $args = $class->BUILDARGS(@_); 1462 | 1463 | my $class_metadata = Lmo::Meta->metadata_for($class); 1464 | 1465 | my @args_to_delete; 1466 | while ( my ($attr, $meta) = each %$class_metadata ) { 1467 | next unless exists $meta->{init_arg}; 1468 | my $init_arg = $meta->{init_arg}; 1469 | 1470 | if ( defined $init_arg ) { 1471 | $args->{$attr} = delete $args->{$init_arg}; 1472 | } 1473 | else { 1474 | push @args_to_delete, $attr; 1475 | } 1476 | } 1477 | 1478 | delete $args->{$_} for @args_to_delete; 1479 | 1480 | for my $attribute ( keys %$args ) { 1481 | if ( my $coerce = $class_metadata->{$attribute}{coerce} ) { 1482 | $args->{$attribute} = $coerce->($args->{$attribute}); 1483 | } 1484 | if ( my $isa_check = $class_metadata->{$attribute}{isa} ) { 1485 | my ($check_name, $check_sub) = @$isa_check; 1486 | $check_sub->($args->{$attribute}); 1487 | } 1488 | } 1489 | 1490 | while ( my ($attribute, $meta) = each %$class_metadata ) { 1491 | next unless $meta->{required}; 1492 | Carp::confess("Attribute ($attribute) is required for $class") 1493 | if ! exists $args->{$attribute} 1494 | } 1495 | 1496 | my $self = bless $args, $class; 1497 | 1498 | my @build_subs; 1499 | my $linearized_isa = mro::get_linear_isa($class); 1500 | 1501 | for my $isa_class ( @$linearized_isa ) { 1502 | unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE}; 1503 | } 1504 | my @args = %$args; 1505 | for my $sub (grep { defined($_) && exists &$_ } @build_subs) { 1506 | $sub->( $self, @args); 1507 | } 1508 | return $self; 1509 | } 1510 | 1511 | sub BUILDARGS { 1512 | shift; # No need for the classname 1513 | if ( @_ == 1 && ref($_[0]) ) { 1514 | Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]") 1515 | unless ref($_[0]) eq ref({}); 1516 | return {%{$_[0]}} # We want a new reference, always 1517 | } 1518 | else { 1519 | return { @_ }; 1520 | } 1521 | } 1522 | 1523 | sub meta { 1524 | my $class = shift; 1525 | $class = Scalar::Util::blessed($class) || $class; 1526 | return Lmo::Meta->new(class => $class); 1527 | } 1528 | 1529 | 1; 1530 | } 1531 | # ########################################################################### 1532 | # End Lmo::Object package 1533 | # ########################################################################### 1534 | 1535 | # ########################################################################### 1536 | # Lmo::Types package 1537 | # This package is a copy without comments from the original. The original 1538 | # with comments and its test file can be found in the Bazaar repository at, 1539 | # lib/Lmo/Types.pm 1540 | # t/lib/Lmo/Types.t 1541 | # See https://launchpad.net/percona-toolkit for more information. 1542 | # ########################################################################### 1543 | { 1544 | package Lmo::Types; 1545 | 1546 | use strict; 1547 | use warnings qw( FATAL all ); 1548 | 1549 | use Carp (); 1550 | use Scalar::Util qw(looks_like_number blessed); 1551 | 1552 | 1553 | our %TYPES = ( 1554 | Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) }, 1555 | Num => sub { defined $_[0] && looks_like_number($_[0]) }, 1556 | Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) }, 1557 | Str => sub { defined $_[0] }, 1558 | Object => sub { defined $_[0] && blessed($_[0]) }, 1559 | FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, 1560 | 1561 | map { 1562 | my $type = /R/ ? $_ : uc $_; 1563 | $_ . "Ref" => sub { ref $_[0] eq $type } 1564 | } qw(Array Code Hash Regexp Glob Scalar) 1565 | ); 1566 | 1567 | sub check_type_constaints { 1568 | my ($attribute, $type_check, $check_name, $val) = @_; 1569 | ( ref($type_check) eq 'CODE' 1570 | ? $type_check->($val) 1571 | : (ref $val eq $type_check 1572 | || ($val && $val eq $type_check) 1573 | || (exists $TYPES{$type_check} && $TYPES{$type_check}->($val))) 1574 | ) 1575 | || Carp::confess( 1576 | qq 1577 | . qq 1578 | . (defined $val ? Lmo::Dumper($val) : 'undef') ) 1579 | } 1580 | 1581 | sub _nested_constraints { 1582 | my ($attribute, $aggregate_type, $type) = @_; 1583 | 1584 | my $inner_types; 1585 | if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { 1586 | $inner_types = _nested_constraints($1, $2); 1587 | } 1588 | else { 1589 | $inner_types = $TYPES{$type}; 1590 | } 1591 | 1592 | if ( $aggregate_type eq 'ArrayRef' ) { 1593 | return sub { 1594 | my ($val) = @_; 1595 | return unless ref($val) eq ref([]); 1596 | 1597 | if ($inner_types) { 1598 | for my $value ( @{$val} ) { 1599 | return unless $inner_types->($value) 1600 | } 1601 | } 1602 | else { 1603 | for my $value ( @{$val} ) { 1604 | return unless $value && ($value eq $type 1605 | || (Scalar::Util::blessed($value) && $value->isa($type))); 1606 | } 1607 | } 1608 | return 1; 1609 | }; 1610 | } 1611 | elsif ( $aggregate_type eq 'Maybe' ) { 1612 | return sub { 1613 | my ($value) = @_; 1614 | return 1 if ! defined($value); 1615 | if ($inner_types) { 1616 | return unless $inner_types->($value) 1617 | } 1618 | else { 1619 | return unless $value eq $type 1620 | || (Scalar::Util::blessed($value) && $value->isa($type)); 1621 | } 1622 | return 1; 1623 | } 1624 | } 1625 | else { 1626 | Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); 1627 | } 1628 | } 1629 | 1630 | 1; 1631 | } 1632 | # ########################################################################### 1633 | # End Lmo::Types package 1634 | # ########################################################################### 1635 | 1636 | # ########################################################################### 1637 | # Lmo package 1638 | # This package is a copy without comments from the original. The original 1639 | # with comments and its test file can be found in the Bazaar repository at, 1640 | # lib/Lmo.pm 1641 | # t/lib/Lmo.t 1642 | # See https://launchpad.net/percona-toolkit for more information. 1643 | # ########################################################################### 1644 | { 1645 | BEGIN { 1646 | $INC{"Lmo.pm"} = __FILE__; 1647 | package Lmo; 1648 | our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. 1649 | 1650 | 1651 | use strict; 1652 | use warnings qw( FATAL all ); 1653 | 1654 | use Carp (); 1655 | use Scalar::Util qw(looks_like_number blessed); 1656 | 1657 | use Lmo::Meta; 1658 | use Lmo::Object; 1659 | use Lmo::Types; 1660 | 1661 | use Lmo::Utils; 1662 | 1663 | my %export_for; 1664 | sub import { 1665 | warnings->import(qw(FATAL all)); 1666 | strict->import(); 1667 | 1668 | my $caller = scalar caller(); # Caller's package 1669 | my %exports = ( 1670 | extends => \&extends, 1671 | has => \&has, 1672 | with => \&with, 1673 | override => \&override, 1674 | confess => \&Carp::confess, 1675 | ); 1676 | 1677 | $export_for{$caller} = \%exports; 1678 | 1679 | for my $keyword ( keys %exports ) { 1680 | _install_coderef "${caller}::$keyword" => $exports{$keyword}; 1681 | } 1682 | 1683 | if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) { 1684 | @_ = "Lmo::Object"; 1685 | goto *{ _glob_for "${caller}::extends" }{CODE}; 1686 | } 1687 | } 1688 | 1689 | sub extends { 1690 | my $caller = scalar caller(); 1691 | for my $class ( @_ ) { 1692 | _load_module($class); 1693 | } 1694 | _set_package_isa($caller, @_); 1695 | _set_inherited_metadata($caller); 1696 | } 1697 | 1698 | sub _load_module { 1699 | my ($class) = @_; 1700 | 1701 | (my $file = $class) =~ s{::|'}{/}g; 1702 | $file .= '.pm'; 1703 | { local $@; eval { require "$file" } } # or warn $@; 1704 | return; 1705 | } 1706 | 1707 | sub with { 1708 | my $package = scalar caller(); 1709 | require Role::Tiny; 1710 | for my $role ( @_ ) { 1711 | _load_module($role); 1712 | _role_attribute_metadata($package, $role); 1713 | } 1714 | Role::Tiny->apply_roles_to_package($package, @_); 1715 | } 1716 | 1717 | sub _role_attribute_metadata { 1718 | my ($package, $role) = @_; 1719 | 1720 | my $package_meta = Lmo::Meta->metadata_for($package); 1721 | my $role_meta = Lmo::Meta->metadata_for($role); 1722 | 1723 | %$package_meta = (%$role_meta, %$package_meta); 1724 | } 1725 | 1726 | sub has { 1727 | my $names = shift; 1728 | my $caller = scalar caller(); 1729 | 1730 | my $class_metadata = Lmo::Meta->metadata_for($caller); 1731 | 1732 | for my $attribute ( ref $names ? @$names : $names ) { 1733 | my %args = @_; 1734 | my $method = ($args{is} || '') eq 'ro' 1735 | ? sub { 1736 | Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}") 1737 | if $#_; 1738 | return $_[0]{$attribute}; 1739 | } 1740 | : sub { 1741 | return $#_ 1742 | ? $_[0]{$attribute} = $_[1] 1743 | : $_[0]{$attribute}; 1744 | }; 1745 | 1746 | $class_metadata->{$attribute} = (); 1747 | 1748 | if ( my $type_check = $args{isa} ) { 1749 | my $check_name = $type_check; 1750 | 1751 | if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { 1752 | $type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type); 1753 | } 1754 | 1755 | my $check_sub = sub { 1756 | my ($new_val) = @_; 1757 | Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val); 1758 | }; 1759 | 1760 | $class_metadata->{$attribute}{isa} = [$check_name, $check_sub]; 1761 | my $orig_method = $method; 1762 | $method = sub { 1763 | $check_sub->($_[1]) if $#_; 1764 | goto &$orig_method; 1765 | }; 1766 | } 1767 | 1768 | if ( my $builder = $args{builder} ) { 1769 | my $original_method = $method; 1770 | $method = sub { 1771 | $#_ 1772 | ? goto &$original_method 1773 | : ! exists $_[0]{$attribute} 1774 | ? $_[0]{$attribute} = $_[0]->$builder 1775 | : goto &$original_method 1776 | }; 1777 | } 1778 | 1779 | if ( my $code = $args{default} ) { 1780 | Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") 1781 | unless ref($code) eq 'CODE'; 1782 | my $original_method = $method; 1783 | $method = sub { 1784 | $#_ 1785 | ? goto &$original_method 1786 | : ! exists $_[0]{$attribute} 1787 | ? $_[0]{$attribute} = $_[0]->$code 1788 | : goto &$original_method 1789 | }; 1790 | } 1791 | 1792 | if ( my $role = $args{does} ) { 1793 | my $original_method = $method; 1794 | $method = sub { 1795 | if ( $#_ ) { 1796 | Carp::confess(qq) 1797 | unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) } 1798 | } 1799 | goto &$original_method 1800 | }; 1801 | } 1802 | 1803 | if ( my $coercion = $args{coerce} ) { 1804 | $class_metadata->{$attribute}{coerce} = $coercion; 1805 | my $original_method = $method; 1806 | $method = sub { 1807 | if ( $#_ ) { 1808 | return $original_method->($_[0], $coercion->($_[1])) 1809 | } 1810 | goto &$original_method; 1811 | } 1812 | } 1813 | 1814 | _install_coderef "${caller}::$attribute" => $method; 1815 | 1816 | if ( $args{required} ) { 1817 | $class_metadata->{$attribute}{required} = 1; 1818 | } 1819 | 1820 | if ($args{clearer}) { 1821 | _install_coderef "${caller}::$args{clearer}" 1822 | => sub { delete shift->{$attribute} } 1823 | } 1824 | 1825 | if ($args{predicate}) { 1826 | _install_coderef "${caller}::$args{predicate}" 1827 | => sub { exists shift->{$attribute} } 1828 | } 1829 | 1830 | if ($args{handles}) { 1831 | _has_handles($caller, $attribute, \%args); 1832 | } 1833 | 1834 | if (exists $args{init_arg}) { 1835 | $class_metadata->{$attribute}{init_arg} = $args{init_arg}; 1836 | } 1837 | } 1838 | } 1839 | 1840 | sub _has_handles { 1841 | my ($caller, $attribute, $args) = @_; 1842 | my $handles = $args->{handles}; 1843 | 1844 | my $ref = ref $handles; 1845 | my $kv; 1846 | if ( $ref eq ref [] ) { 1847 | $kv = { map { $_,$_ } @{$handles} }; 1848 | } 1849 | elsif ( $ref eq ref {} ) { 1850 | $kv = $handles; 1851 | } 1852 | elsif ( $ref eq ref qr// ) { 1853 | Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") 1854 | unless $args->{isa}; 1855 | my $target_class = $args->{isa}; 1856 | $kv = { 1857 | map { $_, $_ } 1858 | grep { $_ =~ $handles } 1859 | grep { !exists $Lmo::Object::{$_} && $target_class->can($_) } 1860 | grep { !$export_for{$target_class}->{$_} } 1861 | keys %{ _stash_for $target_class } 1862 | }; 1863 | } 1864 | else { 1865 | Carp::confess("handles for $ref not yet implemented"); 1866 | } 1867 | 1868 | while ( my ($method, $target) = each %{$kv} ) { 1869 | my $name = _glob_for "${caller}::$method"; 1870 | Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") 1871 | if defined &$name; 1872 | 1873 | my ($target, @curried_args) = ref($target) ? @$target : $target; 1874 | *$name = sub { 1875 | my $self = shift; 1876 | my $delegate_to = $self->$attribute(); 1877 | my $error = "Cannot delegate $method to $target because the value of $attribute"; 1878 | Carp::confess("$error is not defined") unless $delegate_to; 1879 | Carp::confess("$error is not an object (got '$delegate_to')") 1880 | unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); 1881 | return $delegate_to->$target(@curried_args, @_); 1882 | } 1883 | } 1884 | } 1885 | 1886 | sub _set_package_isa { 1887 | my ($package, @new_isa) = @_; 1888 | my $package_isa = \*{ _glob_for "${package}::ISA" }; 1889 | @{*$package_isa} = @new_isa; 1890 | } 1891 | 1892 | sub _set_inherited_metadata { 1893 | my $class = shift; 1894 | my $class_metadata = Lmo::Meta->metadata_for($class); 1895 | my $linearized_isa = mro::get_linear_isa($class); 1896 | my %new_metadata; 1897 | 1898 | for my $isa_class (reverse @$linearized_isa) { 1899 | my $isa_metadata = Lmo::Meta->metadata_for($isa_class); 1900 | %new_metadata = ( 1901 | %new_metadata, 1902 | %$isa_metadata, 1903 | ); 1904 | } 1905 | %$class_metadata = %new_metadata; 1906 | } 1907 | 1908 | sub unimport { 1909 | my $caller = scalar caller(); 1910 | my $target = caller; 1911 | _unimport_coderefs($target, keys %{$export_for{$caller}}); 1912 | } 1913 | 1914 | sub Dumper { 1915 | require Data::Dumper; 1916 | local $Data::Dumper::Indent = 0; 1917 | local $Data::Dumper::Sortkeys = 0; 1918 | local $Data::Dumper::Quotekeys = 0; 1919 | local $Data::Dumper::Terse = 1; 1920 | 1921 | Data::Dumper::Dumper(@_) 1922 | } 1923 | 1924 | BEGIN { 1925 | if ($] >= 5.010) { 1926 | { local $@; require mro; } 1927 | } 1928 | else { 1929 | local $@; 1930 | eval { 1931 | require MRO::Compat; 1932 | } or do { 1933 | *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { 1934 | no strict 'refs'; 1935 | 1936 | my $classname = shift; 1937 | 1938 | my @lin = ($classname); 1939 | my %stored; 1940 | foreach my $parent (@{"$classname\::ISA"}) { 1941 | my $plin = mro::get_linear_isa_dfs($parent); 1942 | foreach (@$plin) { 1943 | next if exists $stored{$_}; 1944 | push(@lin, $_); 1945 | $stored{$_} = 1; 1946 | } 1947 | } 1948 | return \@lin; 1949 | }; 1950 | } 1951 | } 1952 | } 1953 | 1954 | sub override { 1955 | my ($methods, $code) = @_; 1956 | my $caller = scalar caller; 1957 | 1958 | for my $method ( ref($methods) ? @$methods : $methods ) { 1959 | my $full_method = "${caller}::${method}"; 1960 | *{_glob_for $full_method} = $code; 1961 | } 1962 | } 1963 | 1964 | } 1965 | 1; 1966 | } 1967 | # ########################################################################### 1968 | # End Lmo package 1969 | # ########################################################################### 1970 | 1971 | # ########################################################################### 1972 | # VersionParser package 1973 | # This package is a copy without comments from the original. The original 1974 | # with comments and its test file can be found in the Bazaar repository at, 1975 | # lib/VersionParser.pm 1976 | # t/lib/VersionParser.t 1977 | # See https://launchpad.net/percona-toolkit for more information. 1978 | # ########################################################################### 1979 | { 1980 | package VersionParser; 1981 | 1982 | use Lmo; 1983 | use Scalar::Util qw(blessed); 1984 | use English qw(-no_match_vars); 1985 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 1986 | 1987 | use overload ( 1988 | '""' => "version", 1989 | '<=>' => "cmp", 1990 | 'cmp' => "cmp", 1991 | fallback => 1, 1992 | ); 1993 | 1994 | use Carp (); 1995 | 1996 | our $VERSION = 0.01; 1997 | 1998 | has major => ( 1999 | is => 'ro', 2000 | isa => 'Int', 2001 | required => 1, 2002 | ); 2003 | 2004 | has [qw( minor revision )] => ( 2005 | is => 'ro', 2006 | isa => 'Num', 2007 | ); 2008 | 2009 | has flavor => ( 2010 | is => 'ro', 2011 | isa => 'Str', 2012 | default => sub { 'Unknown' }, 2013 | ); 2014 | 2015 | has innodb_version => ( 2016 | is => 'ro', 2017 | isa => 'Str', 2018 | default => sub { 'NO' }, 2019 | ); 2020 | 2021 | sub series { 2022 | my $self = shift; 2023 | return $self->_join_version($self->major, $self->minor); 2024 | } 2025 | 2026 | sub version { 2027 | my $self = shift; 2028 | return $self->_join_version($self->major, $self->minor, $self->revision); 2029 | } 2030 | 2031 | sub is_in { 2032 | my ($self, $target) = @_; 2033 | 2034 | return $self eq $target; 2035 | } 2036 | 2037 | sub _join_version { 2038 | my ($self, @parts) = @_; 2039 | 2040 | return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts; 2041 | } 2042 | sub _split_version { 2043 | my ($self, $str) = @_; 2044 | my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g; 2045 | return @version_parts[0..2]; 2046 | } 2047 | 2048 | sub normalized_version { 2049 | my ( $self ) = @_; 2050 | my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major, 2051 | $self->minor, 2052 | $self->revision); 2053 | PTDEBUG && _d($self->version, 'normalizes to', $result); 2054 | return $result; 2055 | } 2056 | 2057 | sub comment { 2058 | my ( $self, $cmd ) = @_; 2059 | my $v = $self->normalized_version(); 2060 | 2061 | return "/*!$v $cmd */" 2062 | } 2063 | 2064 | my @methods = qw(major minor revision); 2065 | sub cmp { 2066 | my ($left, $right) = @_; 2067 | my $right_obj = (blessed($right) && $right->isa(ref($left))) 2068 | ? $right 2069 | : ref($left)->new($right); 2070 | 2071 | my $retval = 0; 2072 | for my $m ( @methods ) { 2073 | last unless defined($left->$m) && defined($right_obj->$m); 2074 | $retval = $left->$m <=> $right_obj->$m; 2075 | last if $retval; 2076 | } 2077 | return $retval; 2078 | } 2079 | 2080 | sub BUILDARGS { 2081 | my $self = shift; 2082 | 2083 | if ( @_ == 1 ) { 2084 | my %args; 2085 | if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) { 2086 | PTDEBUG && _d("VersionParser got a dbh, trying to get the version"); 2087 | my $dbh = $_[0]; 2088 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; 2089 | my $query = eval { 2090 | $dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} }) 2091 | }; 2092 | if ( $query ) { 2093 | $query = { map { $_->{variable_name} => $_->{value} } @$query }; 2094 | @args{@methods} = $self->_split_version($query->{version}); 2095 | $args{flavor} = delete $query->{version_comment} 2096 | if $query->{version_comment}; 2097 | } 2098 | elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) { 2099 | @args{@methods} = $self->_split_version($query); 2100 | } 2101 | else { 2102 | Carp::confess("Couldn't get the version from the dbh while " 2103 | . "creating a VersionParser object: $@"); 2104 | } 2105 | $args{innodb_version} = eval { $self->_innodb_version($dbh) }; 2106 | } 2107 | elsif ( !ref($_[0]) ) { 2108 | @args{@methods} = $self->_split_version($_[0]); 2109 | } 2110 | 2111 | for my $method (@methods) { 2112 | delete $args{$method} unless defined $args{$method}; 2113 | } 2114 | @_ = %args if %args; 2115 | } 2116 | 2117 | return $self->SUPER::BUILDARGS(@_); 2118 | } 2119 | 2120 | sub _innodb_version { 2121 | my ( $self, $dbh ) = @_; 2122 | return unless $dbh; 2123 | my $innodb_version = "NO"; 2124 | 2125 | my ($innodb) = 2126 | grep { $_->{engine} =~ m/InnoDB/i } 2127 | map { 2128 | my %hash; 2129 | @hash{ map { lc $_ } keys %$_ } = values %$_; 2130 | \%hash; 2131 | } 2132 | @{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) }; 2133 | if ( $innodb ) { 2134 | PTDEBUG && _d("InnoDB support:", $innodb->{support}); 2135 | if ( $innodb->{support} =~ m/YES|DEFAULT/i ) { 2136 | my $vars = $dbh->selectrow_hashref( 2137 | "SHOW VARIABLES LIKE 'innodb_version'"); 2138 | $innodb_version = !$vars ? "BUILTIN" 2139 | : ($vars->{Value} || $vars->{value}); 2140 | } 2141 | else { 2142 | $innodb_version = $innodb->{support}; # probably DISABLED or NO 2143 | } 2144 | } 2145 | 2146 | PTDEBUG && _d("InnoDB version:", $innodb_version); 2147 | return $innodb_version; 2148 | } 2149 | 2150 | sub _d { 2151 | my ($package, undef, $line) = caller 0; 2152 | @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 2153 | map { defined $_ ? $_ : 'undef' } 2154 | @_; 2155 | print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 2156 | } 2157 | 2158 | no Lmo; 2159 | 1; 2160 | } 2161 | # ########################################################################### 2162 | # End VersionParser package 2163 | # ########################################################################### 2164 | 2165 | # ########################################################################### 2166 | # DSNParser package 2167 | # This package is a copy without comments from the original. The original 2168 | # with comments and its test file can be found in the Bazaar repository at, 2169 | # lib/DSNParser.pm 2170 | # t/lib/DSNParser.t 2171 | # See https://launchpad.net/percona-toolkit for more information. 2172 | # ########################################################################### 2173 | { 2174 | package DSNParser; 2175 | 2176 | use strict; 2177 | use warnings FATAL => 'all'; 2178 | use English qw(-no_match_vars); 2179 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 2180 | 2181 | use Data::Dumper; 2182 | $Data::Dumper::Indent = 0; 2183 | $Data::Dumper::Quotekeys = 0; 2184 | 2185 | my $dsn_sep = qr/(? {} # h, P, u, etc. Should come from DSN OPTIONS section in POD. 2199 | }; 2200 | foreach my $opt ( @{$args{opts}} ) { 2201 | if ( !$opt->{key} || !$opt->{desc} ) { 2202 | die "Invalid DSN option: ", Dumper($opt); 2203 | } 2204 | PTDEBUG && _d('DSN option:', 2205 | join(', ', 2206 | map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') } 2207 | keys %$opt 2208 | ) 2209 | ); 2210 | $self->{opts}->{$opt->{key}} = { 2211 | dsn => $opt->{dsn}, 2212 | desc => $opt->{desc}, 2213 | copy => $opt->{copy} || 0, 2214 | }; 2215 | } 2216 | return bless $self, $class; 2217 | } 2218 | 2219 | sub prop { 2220 | my ( $self, $prop, $value ) = @_; 2221 | if ( @_ > 2 ) { 2222 | PTDEBUG && _d('Setting', $prop, 'property'); 2223 | $self->{$prop} = $value; 2224 | } 2225 | return $self->{$prop}; 2226 | } 2227 | 2228 | sub parse { 2229 | my ( $self, $dsn, $prev, $defaults ) = @_; 2230 | if ( !$dsn ) { 2231 | PTDEBUG && _d('No DSN to parse'); 2232 | return; 2233 | } 2234 | PTDEBUG && _d('Parsing', $dsn); 2235 | $prev ||= {}; 2236 | $defaults ||= {}; 2237 | my %given_props; 2238 | my %final_props; 2239 | my $opts = $self->{opts}; 2240 | 2241 | foreach my $dsn_part ( split($dsn_sep, $dsn) ) { 2242 | $dsn_part =~ s/\\,/,/g; 2243 | if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) { 2244 | $given_props{$prop_key} = $prop_val; 2245 | } 2246 | else { 2247 | PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part); 2248 | $given_props{h} = $dsn_part; 2249 | } 2250 | } 2251 | 2252 | foreach my $key ( keys %$opts ) { 2253 | PTDEBUG && _d('Finding value for', $key); 2254 | $final_props{$key} = $given_props{$key}; 2255 | if ( !defined $final_props{$key} 2256 | && defined $prev->{$key} && $opts->{$key}->{copy} ) 2257 | { 2258 | $final_props{$key} = $prev->{$key}; 2259 | PTDEBUG && _d('Copying value for', $key, 'from previous DSN'); 2260 | } 2261 | if ( !defined $final_props{$key} ) { 2262 | $final_props{$key} = $defaults->{$key}; 2263 | PTDEBUG && _d('Copying value for', $key, 'from defaults'); 2264 | } 2265 | } 2266 | 2267 | foreach my $key ( keys %given_props ) { 2268 | die "Unknown DSN option '$key' in '$dsn'. For more details, " 2269 | . "please use the --help option, or try 'perldoc $PROGRAM_NAME' " 2270 | . "for complete documentation." 2271 | unless exists $opts->{$key}; 2272 | } 2273 | if ( (my $required = $self->prop('required')) ) { 2274 | foreach my $key ( keys %$required ) { 2275 | die "Missing required DSN option '$key' in '$dsn'. For more details, " 2276 | . "please use the --help option, or try 'perldoc $PROGRAM_NAME' " 2277 | . "for complete documentation." 2278 | unless $final_props{$key}; 2279 | } 2280 | } 2281 | 2282 | return \%final_props; 2283 | } 2284 | 2285 | sub parse_options { 2286 | my ( $self, $o ) = @_; 2287 | die 'I need an OptionParser object' unless ref $o eq 'OptionParser'; 2288 | my $dsn_string 2289 | = join(',', 2290 | map { "$_=".$o->get($_); } 2291 | grep { $o->has($_) && $o->get($_) } 2292 | keys %{$self->{opts}} 2293 | ); 2294 | PTDEBUG && _d('DSN string made from options:', $dsn_string); 2295 | return $self->parse($dsn_string); 2296 | } 2297 | 2298 | sub as_string { 2299 | my ( $self, $dsn, $props ) = @_; 2300 | return $dsn unless ref $dsn; 2301 | my @keys = $props ? @$props : sort keys %$dsn; 2302 | return join(',', 2303 | map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) } 2304 | grep { 2305 | exists $self->{opts}->{$_} 2306 | && exists $dsn->{$_} 2307 | && defined $dsn->{$_} 2308 | } @keys); 2309 | } 2310 | 2311 | sub usage { 2312 | my ( $self ) = @_; 2313 | my $usage 2314 | = "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n" 2315 | . " KEY COPY MEANING\n" 2316 | . " === ==== =============================================\n"; 2317 | my %opts = %{$self->{opts}}; 2318 | foreach my $key ( sort keys %opts ) { 2319 | $usage .= " $key " 2320 | . ($opts{$key}->{copy} ? 'yes ' : 'no ') 2321 | . ($opts{$key}->{desc} || '[No description]') 2322 | . "\n"; 2323 | } 2324 | $usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n"; 2325 | return $usage; 2326 | } 2327 | 2328 | sub get_cxn_params { 2329 | my ( $self, $info ) = @_; 2330 | my $dsn; 2331 | my %opts = %{$self->{opts}}; 2332 | my $driver = $self->prop('dbidriver') || ''; 2333 | if ( $driver eq 'Pg' ) { 2334 | $dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';' 2335 | . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" } 2336 | grep { defined $info->{$_} } 2337 | qw(h P)); 2338 | } 2339 | else { 2340 | $dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';' 2341 | . join(';', map { "$opts{$_}->{dsn}=$info->{$_}" } 2342 | grep { defined $info->{$_} } 2343 | qw(F h P S A)) 2344 | . ';mysql_read_default_group=client' 2345 | . ($info->{L} ? ';mysql_local_infile=1' : ''); 2346 | } 2347 | PTDEBUG && _d($dsn); 2348 | return ($dsn, $info->{u}, $info->{p}); 2349 | } 2350 | 2351 | sub fill_in_dsn { 2352 | my ( $self, $dbh, $dsn ) = @_; 2353 | my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name'); 2354 | my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()'); 2355 | $user =~ s/@.*//; 2356 | $dsn->{h} ||= $vars->{hostname}->{Value}; 2357 | $dsn->{S} ||= $vars->{'socket'}->{Value}; 2358 | $dsn->{P} ||= $vars->{port}->{Value}; 2359 | $dsn->{u} ||= $user; 2360 | $dsn->{D} ||= $db; 2361 | } 2362 | 2363 | sub get_dbh { 2364 | my ( $self, $cxn_string, $user, $pass, $opts ) = @_; 2365 | $opts ||= {}; 2366 | my $defaults = { 2367 | AutoCommit => 0, 2368 | RaiseError => 1, 2369 | PrintError => 0, 2370 | ShowErrorStatement => 1, 2371 | mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0), 2372 | }; 2373 | @{$defaults}{ keys %$opts } = values %$opts; 2374 | if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension 2375 | $defaults->{mysql_local_infile} = 1; 2376 | } 2377 | 2378 | if ( $opts->{mysql_use_result} ) { 2379 | $defaults->{mysql_use_result} = 1; 2380 | } 2381 | 2382 | if ( !$have_dbi ) { 2383 | die "Cannot connect to MySQL because the Perl DBI module is not " 2384 | . "installed or not found. Run 'perl -MDBI' to see the directories " 2385 | . "that Perl searches for DBI. If DBI is not installed, try:\n" 2386 | . " Debian/Ubuntu apt-get install libdbi-perl\n" 2387 | . " RHEL/CentOS yum install perl-DBI\n" 2388 | . " OpenSolaris pkg install pkg:/SUNWpmdbi\n"; 2389 | 2390 | } 2391 | 2392 | my $dbh; 2393 | my $tries = 2; 2394 | while ( !$dbh && $tries-- ) { 2395 | PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, 2396 | join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults )); 2397 | 2398 | $dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) }; 2399 | 2400 | if ( !$dbh && $EVAL_ERROR ) { 2401 | if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) { 2402 | die "Cannot connect to MySQL because the Perl DBD::mysql module is " 2403 | . "not installed or not found. Run 'perl -MDBD::mysql' to see " 2404 | . "the directories that Perl searches for DBD::mysql. If " 2405 | . "DBD::mysql is not installed, try:\n" 2406 | . " Debian/Ubuntu apt-get install libdbd-mysql-perl\n" 2407 | . " RHEL/CentOS yum install perl-DBD-MySQL\n" 2408 | . " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n"; 2409 | } 2410 | elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) { 2411 | PTDEBUG && _d('Going to try again without utf8 support'); 2412 | delete $defaults->{mysql_enable_utf8}; 2413 | } 2414 | if ( !$tries ) { 2415 | die $EVAL_ERROR; 2416 | } 2417 | } 2418 | } 2419 | 2420 | if ( $cxn_string =~ m/mysql/i ) { 2421 | my $sql; 2422 | 2423 | $sql = 'SELECT @@SQL_MODE'; 2424 | PTDEBUG && _d($dbh, $sql); 2425 | my ($sql_mode) = eval { $dbh->selectrow_array($sql) }; 2426 | if ( $EVAL_ERROR ) { 2427 | die "Error getting the current SQL_MODE: $EVAL_ERROR"; 2428 | } 2429 | 2430 | if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) { 2431 | $sql = qq{/*!40101 SET NAMES "$charset"*/}; 2432 | PTDEBUG && _d($dbh, $sql); 2433 | eval { $dbh->do($sql) }; 2434 | if ( $EVAL_ERROR ) { 2435 | die "Error setting NAMES to $charset: $EVAL_ERROR"; 2436 | } 2437 | PTDEBUG && _d('Enabling charset for STDOUT'); 2438 | if ( $charset eq 'utf8' ) { 2439 | binmode(STDOUT, ':utf8') 2440 | or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR"; 2441 | } 2442 | else { 2443 | binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR"; 2444 | } 2445 | } 2446 | 2447 | if ( my $vars = $self->prop('set-vars') ) { 2448 | $self->set_vars($dbh, $vars); 2449 | } 2450 | 2451 | $sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1' 2452 | . '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO' 2453 | . ($sql_mode ? ",$sql_mode" : '') 2454 | . '\'*/'; 2455 | PTDEBUG && _d($dbh, $sql); 2456 | eval { $dbh->do($sql) }; 2457 | if ( $EVAL_ERROR ) { 2458 | die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE" 2459 | . ($sql_mode ? " and $sql_mode" : '') 2460 | . ": $EVAL_ERROR"; 2461 | } 2462 | } 2463 | 2464 | PTDEBUG && _d('DBH info: ', 2465 | $dbh, 2466 | Dumper($dbh->selectrow_hashref( 2467 | 'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')), 2468 | 'Connection info:', $dbh->{mysql_hostinfo}, 2469 | 'Character set info:', Dumper($dbh->selectall_arrayref( 2470 | "SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})), 2471 | '$DBD::mysql::VERSION:', $DBD::mysql::VERSION, 2472 | '$DBI::VERSION:', $DBI::VERSION, 2473 | ); 2474 | 2475 | return $dbh; 2476 | } 2477 | 2478 | sub get_hostname { 2479 | my ( $self, $dbh ) = @_; 2480 | if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) { 2481 | return $host; 2482 | } 2483 | my ( $hostname, $one ) = $dbh->selectrow_array( 2484 | 'SELECT /*!50038 @@hostname, */ 1'); 2485 | return $hostname; 2486 | } 2487 | 2488 | sub disconnect { 2489 | my ( $self, $dbh ) = @_; 2490 | PTDEBUG && $self->print_active_handles($dbh); 2491 | $dbh->disconnect; 2492 | } 2493 | 2494 | sub print_active_handles { 2495 | my ( $self, $thing, $level ) = @_; 2496 | $level ||= 0; 2497 | printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level, 2498 | $thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : '')) 2499 | or die "Cannot print: $OS_ERROR"; 2500 | foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) { 2501 | $self->print_active_handles( $handle, $level + 1 ); 2502 | } 2503 | } 2504 | 2505 | sub copy { 2506 | my ( $self, $dsn_1, $dsn_2, %args ) = @_; 2507 | die 'I need a dsn_1 argument' unless $dsn_1; 2508 | die 'I need a dsn_2 argument' unless $dsn_2; 2509 | my %new_dsn = map { 2510 | my $key = $_; 2511 | my $val; 2512 | if ( $args{overwrite} ) { 2513 | $val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key}; 2514 | } 2515 | else { 2516 | $val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key}; 2517 | } 2518 | $key => $val; 2519 | } keys %{$self->{opts}}; 2520 | return \%new_dsn; 2521 | } 2522 | 2523 | sub set_vars { 2524 | my ($self, $dbh, $vars) = @_; 2525 | 2526 | return unless $vars; 2527 | 2528 | foreach my $var ( sort keys %$vars ) { 2529 | my $val = $vars->{$var}->{val}; 2530 | 2531 | (my $quoted_var = $var) =~ s/_/\\_/; 2532 | my ($var_exists, $current_val); 2533 | eval { 2534 | ($var_exists, $current_val) = $dbh->selectrow_array( 2535 | "SHOW VARIABLES LIKE '$quoted_var'"); 2536 | }; 2537 | my $e = $EVAL_ERROR; 2538 | if ( $e ) { 2539 | PTDEBUG && _d($e); 2540 | } 2541 | 2542 | if ( $vars->{$var}->{default} && !$var_exists ) { 2543 | PTDEBUG && _d('Not setting default var', $var, 2544 | 'because it does not exist'); 2545 | next; 2546 | } 2547 | 2548 | if ( $current_val && $current_val eq $val ) { 2549 | PTDEBUG && _d('Not setting var', $var, 'because its value', 2550 | 'is already', $val); 2551 | next; 2552 | } 2553 | 2554 | my $sql = "SET SESSION $var=$val"; 2555 | PTDEBUG && _d($dbh, $sql); 2556 | eval { $dbh->do($sql) }; 2557 | if ( my $set_error = $EVAL_ERROR ) { 2558 | chomp($set_error); 2559 | $set_error =~ s/ at \S+ line \d+//; 2560 | my $msg = "Error setting $var: $set_error"; 2561 | if ( $current_val ) { 2562 | $msg .= " The current value for $var is $current_val. " 2563 | . "If the variable is read only (not dynamic), specify " 2564 | . "--set-vars $var=$current_val to avoid this warning, " 2565 | . "else manually set the variable and restart MySQL."; 2566 | } 2567 | warn $msg . "\n\n"; 2568 | } 2569 | } 2570 | 2571 | return; 2572 | } 2573 | 2574 | sub _d { 2575 | my ($package, undef, $line) = caller 0; 2576 | @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 2577 | map { defined $_ ? $_ : 'undef' } 2578 | @_; 2579 | print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 2580 | } 2581 | 2582 | 1; 2583 | } 2584 | # ########################################################################### 2585 | # End DSNParser package 2586 | # ########################################################################### 2587 | 2588 | # ########################################################################### 2589 | # MasterSlave package 2590 | # This package is a copy without comments from the original. The original 2591 | # with comments and its test file can be found in the Bazaar repository at, 2592 | # lib/MasterSlave.pm 2593 | # t/lib/MasterSlave.t 2594 | # See https://launchpad.net/percona-toolkit for more information. 2595 | # ########################################################################### 2596 | { 2597 | package MasterSlave; 2598 | 2599 | use strict; 2600 | use warnings FATAL => 'all'; 2601 | use English qw(-no_match_vars); 2602 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 2603 | 2604 | sub check_recursion_method { 2605 | my ($methods) = @_; 2606 | 2607 | if ( @$methods != 1 ) { 2608 | if ( grep({ !m/processlist|hosts/i } @$methods) 2609 | && $methods->[0] !~ /^dsn=/i ) 2610 | { 2611 | die "Invalid combination of recursion methods: " 2612 | . join(", ", map { defined($_) ? $_ : 'undef' } @$methods) . ". " 2613 | . "Only hosts and processlist may be combined.\n" 2614 | } 2615 | } 2616 | else { 2617 | my ($method) = @$methods; 2618 | die "Invalid recursion method: " . ( $method || 'undef' ) 2619 | unless $method && $method =~ m/^(?:processlist$|hosts$|none$|dsn=)/i; 2620 | } 2621 | } 2622 | 2623 | sub new { 2624 | my ( $class, %args ) = @_; 2625 | my @required_args = qw(OptionParser DSNParser Quoter); 2626 | foreach my $arg ( @required_args ) { 2627 | die "I need a $arg argument" unless $args{$arg}; 2628 | } 2629 | my $self = { 2630 | %args, 2631 | replication_thread => {}, 2632 | }; 2633 | return bless $self, $class; 2634 | } 2635 | 2636 | sub get_slaves { 2637 | my ($self, %args) = @_; 2638 | my @required_args = qw(make_cxn); 2639 | foreach my $arg ( @required_args ) { 2640 | die "I need a $arg argument" unless $args{$arg}; 2641 | } 2642 | my ($make_cxn) = @args{@required_args}; 2643 | 2644 | my $slaves = []; 2645 | my $dp = $self->{DSNParser}; 2646 | my $methods = $self->_resolve_recursion_methods($args{dsn}); 2647 | 2648 | return $slaves unless @$methods; 2649 | 2650 | if ( grep { m/processlist|hosts/i } @$methods ) { 2651 | my @required_args = qw(dbh dsn); 2652 | foreach my $arg ( @required_args ) { 2653 | die "I need a $arg argument" unless $args{$arg}; 2654 | } 2655 | my ($dbh, $dsn) = @args{@required_args}; 2656 | 2657 | $self->recurse_to_slaves( 2658 | { dbh => $dbh, 2659 | dsn => $dsn, 2660 | callback => sub { 2661 | my ( $dsn, $dbh, $level, $parent ) = @_; 2662 | return unless $level; 2663 | PTDEBUG && _d('Found slave:', $dp->as_string($dsn)); 2664 | push @$slaves, $make_cxn->(dsn => $dsn, dbh => $dbh); 2665 | return; 2666 | }, 2667 | } 2668 | ); 2669 | } 2670 | elsif ( $methods->[0] =~ m/^dsn=/i ) { 2671 | (my $dsn_table_dsn = join ",", @$methods) =~ s/^dsn=//i; 2672 | $slaves = $self->get_cxn_from_dsn_table( 2673 | %args, 2674 | dsn_table_dsn => $dsn_table_dsn, 2675 | ); 2676 | } 2677 | elsif ( $methods->[0] =~ m/none/i ) { 2678 | PTDEBUG && _d('Not getting to slaves'); 2679 | } 2680 | else { 2681 | die "Unexpected recursion methods: @$methods"; 2682 | } 2683 | 2684 | return $slaves; 2685 | } 2686 | 2687 | sub _resolve_recursion_methods { 2688 | my ($self, $dsn) = @_; 2689 | my $o = $self->{OptionParser}; 2690 | if ( $o->got('recursion-method') ) { 2691 | return $o->get('recursion-method'); 2692 | } 2693 | elsif ( $dsn && ($dsn->{P} || 3306) != 3306 ) { 2694 | PTDEBUG && _d('Port number is non-standard; using only hosts method'); 2695 | return [qw(hosts)]; 2696 | } 2697 | else { 2698 | return $o->get('recursion-method'); 2699 | } 2700 | } 2701 | 2702 | 2703 | sub recurse_to_slaves { 2704 | my ( $self, $args, $level ) = @_; 2705 | $level ||= 0; 2706 | my $dp = $self->{DSNParser}; 2707 | my $recurse = $args->{recurse} || $self->{OptionParser}->get('recurse'); 2708 | my $dsn = $args->{dsn}; 2709 | 2710 | my $methods = $self->_resolve_recursion_methods($dsn); 2711 | PTDEBUG && _d('Recursion methods:', @$methods); 2712 | if ( lc($methods->[0]) eq 'none' ) { 2713 | PTDEBUG && _d('Not recursing to slaves'); 2714 | return; 2715 | } 2716 | 2717 | my $dbh; 2718 | eval { 2719 | $dbh = $args->{dbh} || $dp->get_dbh( 2720 | $dp->get_cxn_params($dsn), { AutoCommit => 1 }); 2721 | PTDEBUG && _d('Connected to', $dp->as_string($dsn)); 2722 | }; 2723 | if ( $EVAL_ERROR ) { 2724 | print STDERR "Cannot connect to ", $dp->as_string($dsn), "\n" 2725 | or die "Cannot print: $OS_ERROR"; 2726 | return; 2727 | } 2728 | 2729 | 2730 | my $sql = 'SELECT @@SERVER_ID'; 2731 | PTDEBUG && _d($sql); 2732 | my ($id) = $dbh->selectrow_array($sql); 2733 | PTDEBUG && _d('Working on server ID', $id); 2734 | my $master_thinks_i_am = $dsn->{server_id}; 2735 | if ( !defined $id 2736 | || ( defined $master_thinks_i_am && $master_thinks_i_am != $id ) 2737 | || $args->{server_ids_seen}->{$id}++ 2738 | ) { 2739 | PTDEBUG && _d('Server ID seen, or not what master said'); 2740 | if ( $args->{skip_callback} ) { 2741 | $args->{skip_callback}->($dsn, $dbh, $level, $args->{parent}); 2742 | } 2743 | return; 2744 | } 2745 | 2746 | $args->{callback}->($dsn, $dbh, $level, $args->{parent}); 2747 | 2748 | if ( !defined $recurse || $level < $recurse ) { 2749 | 2750 | my @slaves = 2751 | grep { !$_->{master_id} || $_->{master_id} == $id } # Only my slaves. 2752 | $self->find_slave_hosts($dp, $dbh, $dsn, $methods); 2753 | 2754 | foreach my $slave ( @slaves ) { 2755 | PTDEBUG && _d('Recursing from', 2756 | $dp->as_string($dsn), 'to', $dp->as_string($slave)); 2757 | $self->recurse_to_slaves( 2758 | { %$args, dsn => $slave, dbh => undef, parent => $dsn }, $level + 1 ); 2759 | } 2760 | } 2761 | } 2762 | 2763 | sub find_slave_hosts { 2764 | my ( $self, $dsn_parser, $dbh, $dsn, $methods ) = @_; 2765 | 2766 | PTDEBUG && _d('Looking for slaves on', $dsn_parser->as_string($dsn), 2767 | 'using methods', @$methods); 2768 | 2769 | my @slaves; 2770 | METHOD: 2771 | foreach my $method ( @$methods ) { 2772 | my $find_slaves = "_find_slaves_by_$method"; 2773 | PTDEBUG && _d('Finding slaves with', $find_slaves); 2774 | @slaves = $self->$find_slaves($dsn_parser, $dbh, $dsn); 2775 | last METHOD if @slaves; 2776 | } 2777 | 2778 | PTDEBUG && _d('Found', scalar(@slaves), 'slaves'); 2779 | return @slaves; 2780 | } 2781 | 2782 | sub _find_slaves_by_processlist { 2783 | my ( $self, $dsn_parser, $dbh, $dsn ) = @_; 2784 | 2785 | my @slaves = map { 2786 | my $slave = $dsn_parser->parse("h=$_", $dsn); 2787 | $slave->{source} = 'processlist'; 2788 | $slave; 2789 | } 2790 | grep { $_ } 2791 | map { 2792 | my ( $host ) = $_->{host} =~ m/^([^:]+):/; 2793 | if ( $host eq 'localhost' ) { 2794 | $host = '127.0.0.1'; # Replication never uses sockets. 2795 | } 2796 | $host; 2797 | } $self->get_connected_slaves($dbh); 2798 | 2799 | return @slaves; 2800 | } 2801 | 2802 | 2803 | sub _find_slaves_by_hosts { 2804 | my ( $self, $dsn_parser, $dbh, $dsn ) = @_; 2805 | 2806 | my @slaves; 2807 | my $sql = 'SHOW SLAVE HOSTS'; 2808 | PTDEBUG && _d($dbh, $sql); 2809 | @slaves = @{$dbh->selectall_arrayref($sql, { Slice => {} })}; 2810 | 2811 | if ( @slaves ) { 2812 | PTDEBUG && _d('Found some SHOW SLAVE HOSTS info'); 2813 | @slaves = map { 2814 | my %hash; 2815 | @hash{ map { lc $_ } keys %$_ } = values %$_; 2816 | my $spec = "h=$hash{host},P=$hash{port}" 2817 | . ( $hash{user} ? ",u=$hash{user}" : '') 2818 | . ( $hash{password} ? ",p=$hash{password}" : ''); 2819 | my $dsn = $dsn_parser->parse($spec, $dsn); 2820 | $dsn->{server_id} = $hash{server_id}; 2821 | $dsn->{master_id} = $hash{master_id}; 2822 | $dsn->{source} = 'hosts'; 2823 | $dsn; 2824 | } @slaves; 2825 | } 2826 | 2827 | return @slaves; 2828 | } 2829 | 2830 | sub get_connected_slaves { 2831 | my ( $self, $dbh ) = @_; 2832 | 2833 | my $show = "SHOW GRANTS FOR "; 2834 | my $user = 'CURRENT_USER()'; 2835 | my $sql = $show . $user; 2836 | PTDEBUG && _d($dbh, $sql); 2837 | 2838 | my $proc; 2839 | eval { 2840 | $proc = grep { 2841 | m/ALL PRIVILEGES.*?\*\.\*|PROCESS/ 2842 | } @{$dbh->selectcol_arrayref($sql)}; 2843 | }; 2844 | if ( $EVAL_ERROR ) { 2845 | 2846 | if ( $EVAL_ERROR =~ m/no such grant defined for user/ ) { 2847 | PTDEBUG && _d('Retrying SHOW GRANTS without host; error:', 2848 | $EVAL_ERROR); 2849 | ($user) = split('@', $user); 2850 | $sql = $show . $user; 2851 | PTDEBUG && _d($sql); 2852 | eval { 2853 | $proc = grep { 2854 | m/ALL PRIVILEGES.*?\*\.\*|PROCESS/ 2855 | } @{$dbh->selectcol_arrayref($sql)}; 2856 | }; 2857 | } 2858 | 2859 | die "Failed to $sql: $EVAL_ERROR" if $EVAL_ERROR; 2860 | } 2861 | if ( !$proc ) { 2862 | die "You do not have the PROCESS privilege"; 2863 | } 2864 | 2865 | $sql = 'SHOW PROCESSLIST'; 2866 | PTDEBUG && _d($dbh, $sql); 2867 | grep { $_->{command} =~ m/Binlog Dump/i } 2868 | map { # Lowercase the column names 2869 | my %hash; 2870 | @hash{ map { lc $_ } keys %$_ } = values %$_; 2871 | \%hash; 2872 | } 2873 | @{$dbh->selectall_arrayref($sql, { Slice => {} })}; 2874 | } 2875 | 2876 | 2877 | sub is_master_of { 2878 | my ( $self, $master, $slave ) = @_; 2879 | my $master_status = $self->get_master_status($master) 2880 | or die "The server specified as a master is not a master"; 2881 | my $slave_status = $self->get_slave_status($slave) 2882 | or die "The server specified as a slave is not a slave"; 2883 | my @connected = $self->get_connected_slaves($master) 2884 | or die "The server specified as a master has no connected slaves"; 2885 | my (undef, $port) = $master->selectrow_array("SHOW VARIABLES LIKE 'port'"); 2886 | 2887 | if ( $port != $slave_status->{master_port} ) { 2888 | die "The slave is connected to $slave_status->{master_port} " 2889 | . "but the master's port is $port"; 2890 | } 2891 | 2892 | if ( !grep { $slave_status->{master_user} eq $_->{user} } @connected ) { 2893 | die "I don't see any slave I/O thread connected with user " 2894 | . $slave_status->{master_user}; 2895 | } 2896 | 2897 | 2898 | if ( ($slave_status->{slave_io_state} || '') 2899 | eq 'Waiting for master to send event' ) 2900 | { 2901 | my ( $master_log_name, $master_log_num ) 2902 | = $master_status->{file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/; 2903 | my ( $slave_log_name, $slave_log_num ) 2904 | = $slave_status->{master_log_file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/; 2905 | if ( $master_log_name ne $slave_log_name 2906 | || abs($master_log_num - $slave_log_num) > 1 ) 2907 | { 2908 | die "The slave thinks it is reading from " 2909 | . "$slave_status->{master_log_file}, but the " 2910 | . "master is writing to $master_status->{file}"; 2911 | } 2912 | } 2913 | return 1; 2914 | } 2915 | 2916 | sub get_master_dsn { 2917 | my ( $self, $dbh, $dsn, $dsn_parser ) = @_; 2918 | my $master = $self->get_slave_status($dbh) or return undef; 2919 | my $spec = "h=$master->{master_host},P=$master->{master_port}"; 2920 | PTDEBUG && _d(" water $dsn_parser->parse($spec, $dsn) "); 2921 | return $dsn_parser->parse($spec, $dsn); 2922 | } 2923 | 2924 | sub get_slave_status { 2925 | my ( $self, $dbh ) = @_; 2926 | if ( !$self->{not_a_slave}->{$dbh} ) { 2927 | my $sth = $self->{sths}->{$dbh}->{SLAVE_STATUS} 2928 | ||= $dbh->prepare('SHOW SLAVE STATUS'); 2929 | PTDEBUG && _d($dbh, 'SHOW SLAVE STATUS'); 2930 | $sth->execute(); 2931 | my ($ss) = @{$sth->fetchall_arrayref({})}; 2932 | 2933 | if ( $ss && %$ss ) { 2934 | $ss = { map { lc($_) => $ss->{$_} } keys %$ss }; # lowercase the keys 2935 | return $ss; 2936 | } 2937 | 2938 | PTDEBUG && _d('This server returns nothing for SHOW SLAVE STATUS'); 2939 | $self->{not_a_slave}->{$dbh}++; 2940 | } 2941 | } 2942 | 2943 | sub get_master_status { 2944 | my ( $self, $dbh ) = @_; 2945 | 2946 | if ( $self->{not_a_master}->{$dbh} ) { 2947 | PTDEBUG && _d('Server on dbh', $dbh, 'is not a master'); 2948 | return; 2949 | } 2950 | 2951 | my $sth = $self->{sths}->{$dbh}->{MASTER_STATUS} 2952 | ||= $dbh->prepare('SHOW MASTER STATUS'); 2953 | PTDEBUG && _d($dbh, 'SHOW MASTER STATUS'); 2954 | $sth->execute(); 2955 | my ($ms) = @{$sth->fetchall_arrayref({})}; 2956 | PTDEBUG && _d( 2957 | $ms ? map { "$_=" . (defined $ms->{$_} ? $ms->{$_} : '') } keys %$ms 2958 | : ''); 2959 | 2960 | if ( !$ms || scalar keys %$ms < 2 ) { 2961 | PTDEBUG && _d('Server on dbh', $dbh, 'does not seem to be a master'); 2962 | $self->{not_a_master}->{$dbh}++; 2963 | } 2964 | 2965 | return { map { lc($_) => $ms->{$_} } keys %$ms }; # lowercase the keys 2966 | } 2967 | 2968 | sub wait_for_master { 2969 | my ( $self, %args ) = @_; 2970 | my @required_args = qw(master_status slave_dbh); 2971 | foreach my $arg ( @required_args ) { 2972 | die "I need a $arg argument" unless $args{$arg}; 2973 | } 2974 | my ($master_status, $slave_dbh) = @args{@required_args}; 2975 | my $timeout = $args{timeout} || 60; 2976 | 2977 | my $result; 2978 | my $waited; 2979 | if ( $master_status ) { 2980 | my $sql = "SELECT MASTER_POS_WAIT('$master_status->{file}', " 2981 | . "$master_status->{position}, $timeout)"; 2982 | PTDEBUG && _d($slave_dbh, $sql); 2983 | my $start = time; 2984 | ($result) = $slave_dbh->selectrow_array($sql); 2985 | 2986 | $waited = time - $start; 2987 | 2988 | PTDEBUG && _d('Result of waiting:', $result); 2989 | PTDEBUG && _d("Waited", $waited, "seconds"); 2990 | } 2991 | else { 2992 | PTDEBUG && _d('Not waiting: this server is not a master'); 2993 | } 2994 | 2995 | return { 2996 | result => $result, 2997 | waited => $waited, 2998 | }; 2999 | } 3000 | 3001 | sub stop_slave { 3002 | my ( $self, $dbh ) = @_; 3003 | my $sth = $self->{sths}->{$dbh}->{STOP_SLAVE} 3004 | ||= $dbh->prepare('STOP SLAVE'); 3005 | PTDEBUG && _d($dbh, $sth->{Statement}); 3006 | $sth->execute(); 3007 | } 3008 | 3009 | sub start_slave { 3010 | my ( $self, $dbh, $pos ) = @_; 3011 | if ( $pos ) { 3012 | my $sql = "START SLAVE UNTIL MASTER_LOG_FILE='$pos->{file}', " 3013 | . "MASTER_LOG_POS=$pos->{position}"; 3014 | PTDEBUG && _d($dbh, $sql); 3015 | $dbh->do($sql); 3016 | } 3017 | else { 3018 | my $sth = $self->{sths}->{$dbh}->{START_SLAVE} 3019 | ||= $dbh->prepare('START SLAVE'); 3020 | PTDEBUG && _d($dbh, $sth->{Statement}); 3021 | $sth->execute(); 3022 | } 3023 | } 3024 | 3025 | sub catchup_to_master { 3026 | my ( $self, $slave, $master, $timeout ) = @_; 3027 | $self->stop_slave($master); 3028 | $self->stop_slave($slave); 3029 | my $slave_status = $self->get_slave_status($slave); 3030 | my $slave_pos = $self->repl_posn($slave_status); 3031 | my $master_status = $self->get_master_status($master); 3032 | my $master_pos = $self->repl_posn($master_status); 3033 | PTDEBUG && _d('Master position:', $self->pos_to_string($master_pos), 3034 | 'Slave position:', $self->pos_to_string($slave_pos)); 3035 | 3036 | my $result; 3037 | if ( $self->pos_cmp($slave_pos, $master_pos) < 0 ) { 3038 | PTDEBUG && _d('Waiting for slave to catch up to master'); 3039 | $self->start_slave($slave, $master_pos); 3040 | 3041 | $result = $self->wait_for_master( 3042 | master_status => $master_status, 3043 | slave_dbh => $slave, 3044 | timeout => $timeout, 3045 | master_status => $master_status 3046 | ); 3047 | if ( !defined $result->{result} ) { 3048 | $slave_status = $self->get_slave_status($slave); 3049 | if ( !$self->slave_is_running($slave_status) ) { 3050 | PTDEBUG && _d('Master position:', 3051 | $self->pos_to_string($master_pos), 3052 | 'Slave position:', $self->pos_to_string($slave_pos)); 3053 | $slave_pos = $self->repl_posn($slave_status); 3054 | if ( $self->pos_cmp($slave_pos, $master_pos) != 0 ) { 3055 | die "MASTER_POS_WAIT() returned NULL but slave has not " 3056 | . "caught up to master"; 3057 | } 3058 | PTDEBUG && _d('Slave is caught up to master and stopped'); 3059 | } 3060 | else { 3061 | die "Slave has not caught up to master and it is still running"; 3062 | } 3063 | } 3064 | } 3065 | else { 3066 | PTDEBUG && _d("Slave is already caught up to master"); 3067 | } 3068 | 3069 | return $result; 3070 | } 3071 | 3072 | sub catchup_to_same_pos { 3073 | my ( $self, $s1_dbh, $s2_dbh ) = @_; 3074 | $self->stop_slave($s1_dbh); 3075 | $self->stop_slave($s2_dbh); 3076 | my $s1_status = $self->get_slave_status($s1_dbh); 3077 | my $s2_status = $self->get_slave_status($s2_dbh); 3078 | my $s1_pos = $self->repl_posn($s1_status); 3079 | my $s2_pos = $self->repl_posn($s2_status); 3080 | if ( $self->pos_cmp($s1_pos, $s2_pos) < 0 ) { 3081 | $self->start_slave($s1_dbh, $s2_pos); 3082 | } 3083 | elsif ( $self->pos_cmp($s2_pos, $s1_pos) < 0 ) { 3084 | $self->start_slave($s2_dbh, $s1_pos); 3085 | } 3086 | 3087 | $s1_status = $self->get_slave_status($s1_dbh); 3088 | $s2_status = $self->get_slave_status($s2_dbh); 3089 | $s1_pos = $self->repl_posn($s1_status); 3090 | $s2_pos = $self->repl_posn($s2_status); 3091 | 3092 | if ( $self->slave_is_running($s1_status) 3093 | || $self->slave_is_running($s2_status) 3094 | || $self->pos_cmp($s1_pos, $s2_pos) != 0) 3095 | { 3096 | die "The servers aren't both stopped at the same position"; 3097 | } 3098 | 3099 | } 3100 | 3101 | sub slave_is_running { 3102 | my ( $self, $slave_status ) = @_; 3103 | return ($slave_status->{slave_sql_running} || 'No') eq 'Yes'; 3104 | } 3105 | 3106 | sub has_slave_updates { 3107 | my ( $self, $dbh ) = @_; 3108 | my $sql = q{SHOW VARIABLES LIKE 'log_slave_updates'}; 3109 | PTDEBUG && _d($dbh, $sql); 3110 | my ($name, $value) = $dbh->selectrow_array($sql); 3111 | return $value && $value =~ m/^(1|ON)$/; 3112 | } 3113 | 3114 | sub repl_posn { 3115 | my ( $self, $status ) = @_; 3116 | if ( exists $status->{file} && exists $status->{position} ) { 3117 | return { 3118 | file => $status->{file}, 3119 | position => $status->{position}, 3120 | }; 3121 | } 3122 | else { 3123 | return { 3124 | file => $status->{relay_master_log_file}, 3125 | position => $status->{exec_master_log_pos}, 3126 | }; 3127 | } 3128 | } 3129 | 3130 | sub get_slave_lag { 3131 | my ( $self, $dbh ) = @_; 3132 | my $stat = $self->get_slave_status($dbh); 3133 | return unless $stat; # server is not a slave 3134 | return $stat->{seconds_behind_master}; 3135 | } 3136 | 3137 | sub pos_cmp { 3138 | my ( $self, $a, $b ) = @_; 3139 | return $self->pos_to_string($a) cmp $self->pos_to_string($b); 3140 | } 3141 | 3142 | sub short_host { 3143 | my ( $self, $dsn ) = @_; 3144 | my ($host, $port); 3145 | if ( $dsn->{master_host} ) { 3146 | $host = $dsn->{master_host}; 3147 | $port = $dsn->{master_port}; 3148 | } 3149 | else { 3150 | $host = $dsn->{h}; 3151 | $port = $dsn->{P}; 3152 | } 3153 | return ($host || '[default]') . ( ($port || 3306) == 3306 ? '' : ":$port" ); 3154 | } 3155 | 3156 | sub is_replication_thread { 3157 | my ( $self, $query, %args ) = @_; 3158 | return unless $query; 3159 | 3160 | my $type = lc($args{type} || 'all'); 3161 | die "Invalid type: $type" 3162 | unless $type =~ m/^binlog_dump|slave_io|slave_sql|all$/i; 3163 | 3164 | my $match = 0; 3165 | if ( $type =~ m/binlog_dump|all/i ) { 3166 | $match = 1 3167 | if ($query->{Command} || $query->{command} || '') eq "Binlog Dump"; 3168 | } 3169 | if ( !$match ) { 3170 | if ( ($query->{User} || $query->{user} || '') eq "system user" ) { 3171 | PTDEBUG && _d("Slave replication thread"); 3172 | if ( $type ne 'all' ) { 3173 | my $state = $query->{State} || $query->{state} || ''; 3174 | 3175 | if ( $state =~ m/^init|end$/ ) { 3176 | PTDEBUG && _d("Special state:", $state); 3177 | $match = 1; 3178 | } 3179 | else { 3180 | my ($slave_sql) = $state =~ m/ 3181 | ^(Waiting\sfor\sthe\snext\sevent 3182 | |Reading\sevent\sfrom\sthe\srelay\slog 3183 | |Has\sread\sall\srelay\slog;\swaiting 3184 | |Making\stemp\sfile 3185 | |Waiting\sfor\sslave\smutex\son\sexit)/xi; 3186 | 3187 | $match = $type eq 'slave_sql' && $slave_sql ? 1 3188 | : $type eq 'slave_io' && !$slave_sql ? 1 3189 | : 0; 3190 | } 3191 | } 3192 | else { 3193 | $match = 1; 3194 | } 3195 | } 3196 | else { 3197 | PTDEBUG && _d('Not system user'); 3198 | } 3199 | 3200 | if ( !defined $args{check_known_ids} || $args{check_known_ids} ) { 3201 | my $id = $query->{Id} || $query->{id}; 3202 | if ( $match ) { 3203 | $self->{replication_thread}->{$id} = 1; 3204 | } 3205 | else { 3206 | if ( $self->{replication_thread}->{$id} ) { 3207 | PTDEBUG && _d("Thread ID is a known replication thread ID"); 3208 | $match = 1; 3209 | } 3210 | } 3211 | } 3212 | } 3213 | 3214 | PTDEBUG && _d('Matches', $type, 'replication thread:', 3215 | ($match ? 'yes' : 'no'), '; match:', $match); 3216 | 3217 | return $match; 3218 | } 3219 | 3220 | 3221 | sub get_replication_filters { 3222 | my ( $self, %args ) = @_; 3223 | my @required_args = qw(dbh); 3224 | foreach my $arg ( @required_args ) { 3225 | die "I need a $arg argument" unless $args{$arg}; 3226 | } 3227 | my ($dbh) = @args{@required_args}; 3228 | 3229 | my %filters = (); 3230 | 3231 | my $status = $self->get_master_status($dbh); 3232 | if ( $status ) { 3233 | map { $filters{$_} = $status->{$_} } 3234 | grep { defined $status->{$_} && $status->{$_} ne '' } 3235 | qw( 3236 | binlog_do_db 3237 | binlog_ignore_db 3238 | ); 3239 | } 3240 | 3241 | $status = $self->get_slave_status($dbh); 3242 | if ( $status ) { 3243 | map { $filters{$_} = $status->{$_} } 3244 | grep { defined $status->{$_} && $status->{$_} ne '' } 3245 | qw( 3246 | replicate_do_db 3247 | replicate_ignore_db 3248 | replicate_do_table 3249 | replicate_ignore_table 3250 | replicate_wild_do_table 3251 | replicate_wild_ignore_table 3252 | ); 3253 | 3254 | my $sql = "SHOW VARIABLES LIKE 'slave_skip_errors'"; 3255 | PTDEBUG && _d($dbh, $sql); 3256 | my $row = $dbh->selectrow_arrayref($sql); 3257 | $filters{slave_skip_errors} = $row->[1] if $row->[1] && $row->[1] ne 'OFF'; 3258 | } 3259 | 3260 | return \%filters; 3261 | } 3262 | 3263 | 3264 | sub pos_to_string { 3265 | my ( $self, $pos ) = @_; 3266 | my $fmt = '%s/%020d'; 3267 | return sprintf($fmt, @{$pos}{qw(file position)}); 3268 | } 3269 | 3270 | sub reset_known_replication_threads { 3271 | my ( $self ) = @_; 3272 | $self->{replication_thread} = {}; 3273 | return; 3274 | } 3275 | 3276 | ## added by waterbinlin@tencent.com 3277 | ## 2015-10-23 3278 | sub get_create_table { 3279 | my ( $self, $dbh, $db, $tbl ) = @_; 3280 | die "I need a dbh parameter" unless $dbh; 3281 | die "I need a db parameter" unless $db; 3282 | die "I need a tbl parameter" unless $tbl; 3283 | my $q = $self->{Quoter}; 3284 | 3285 | my $new_sql_mode 3286 | = q{/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, } 3287 | . q{@@SQL_MODE := '', } 3288 | . q{@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, } 3289 | . q{@@SQL_QUOTE_SHOW_CREATE := 1 */}; 3290 | 3291 | my $old_sql_mode 3292 | = q{/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, } 3293 | . q{@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */}; 3294 | 3295 | PTDEBUG && _d($new_sql_mode); 3296 | eval { $dbh->do($new_sql_mode); }; 3297 | PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR); 3298 | 3299 | my $use_sql = 'USE ' . $q->quote($db); 3300 | PTDEBUG && _d($dbh, $use_sql); 3301 | $dbh->do($use_sql); 3302 | 3303 | my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl); 3304 | PTDEBUG && _d($show_sql); 3305 | my $href; 3306 | eval { $href = $dbh->selectrow_hashref($show_sql); }; 3307 | if ( my $e = $EVAL_ERROR ) { 3308 | PTDEBUG && _d($old_sql_mode); 3309 | $dbh->do($old_sql_mode); 3310 | 3311 | die $e; 3312 | } 3313 | 3314 | PTDEBUG && _d($old_sql_mode); 3315 | $dbh->do($old_sql_mode); 3316 | 3317 | my ($key) = grep { m/create (?:table|view)/i } keys %$href; 3318 | if ( !$key ) { 3319 | die "Error: no 'Create Table' or 'Create View' in result set from " 3320 | . "$show_sql: " . Dumper($href); 3321 | } 3322 | 3323 | return $href->{$key}; 3324 | } 3325 | 3326 | 3327 | sub get_cxn_from_dsn_table { 3328 | my ($self, %args) = @_; 3329 | my @required_args = qw(dsn_table_dsn make_cxn); 3330 | foreach my $arg ( @required_args ) { 3331 | die "I need a $arg argument" unless $args{$arg}; 3332 | } 3333 | my ($dsn_table_dsn, $make_cxn) = @args{@required_args}; 3334 | PTDEBUG && _d('DSN table DSN:', $dsn_table_dsn); 3335 | 3336 | my $dp = $self->{DSNParser}; 3337 | my $q = $self->{Quoter}; 3338 | 3339 | my $dsn = $dp->parse($dsn_table_dsn); 3340 | my $dsn_table; 3341 | if ( $dsn->{D} && $dsn->{t} ) { 3342 | $dsn_table = $q->quote($dsn->{D}, $dsn->{t}); 3343 | } 3344 | elsif ( $dsn->{t} && $dsn->{t} =~ m/\./ ) { 3345 | $dsn_table = $q->quote($q->split_unquote($dsn->{t})); 3346 | } 3347 | else { 3348 | die "DSN table DSN does not specify a database (D) " 3349 | . "or a database-qualified table (t)"; 3350 | } 3351 | 3352 | my $dsn_tbl_cxn = $make_cxn->(dsn => $dsn); 3353 | my $dbh = $dsn_tbl_cxn->connect(); 3354 | my $sql = "SELECT dsn FROM $dsn_table ORDER BY id"; 3355 | PTDEBUG && _d($sql); 3356 | my $dsn_strings = $dbh->selectcol_arrayref($sql); 3357 | my @cxn; 3358 | if ( $dsn_strings ) { 3359 | foreach my $dsn_string ( @$dsn_strings ) { 3360 | PTDEBUG && _d('DSN from DSN table:', $dsn_string); 3361 | push @cxn, $make_cxn->(dsn_string => $dsn_string); 3362 | } 3363 | } 3364 | return \@cxn; 3365 | } 3366 | 3367 | sub _d { 3368 | my ($package, undef, $line) = caller 0; 3369 | @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 3370 | map { defined $_ ? $_ : 'undef' } 3371 | @_; 3372 | print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 3373 | } 3374 | 3375 | 1; 3376 | } 3377 | # ########################################################################### 3378 | # End MasterSlave package 3379 | # ########################################################################### 3380 | 3381 | # ########################################################################### 3382 | # Daemon package 3383 | # This package is a copy without comments from the original. The original 3384 | # with comments and its test file can be found in the Bazaar repository at, 3385 | # lib/Daemon.pm 3386 | # t/lib/Daemon.t 3387 | # See https://launchpad.net/percona-toolkit for more information. 3388 | # ########################################################################### 3389 | { 3390 | package Daemon; 3391 | 3392 | use strict; 3393 | use warnings FATAL => 'all'; 3394 | use English qw(-no_match_vars); 3395 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 3396 | 3397 | use POSIX qw(setsid); 3398 | 3399 | sub new { 3400 | my ( $class, %args ) = @_; 3401 | foreach my $arg ( qw(o) ) { 3402 | die "I need a $arg argument" unless $args{$arg}; 3403 | } 3404 | my $o = $args{o}; 3405 | my $self = { 3406 | o => $o, 3407 | log_file => $o->has('log') ? $o->get('log') : undef, 3408 | PID_file => $o->has('pid') ? $o->get('pid') : undef, 3409 | }; 3410 | 3411 | check_PID_file(undef, $self->{PID_file}); 3412 | 3413 | PTDEBUG && _d('Daemonized child will log to', $self->{log_file}); 3414 | return bless $self, $class; 3415 | } 3416 | 3417 | sub daemonize { 3418 | my ( $self ) = @_; 3419 | 3420 | PTDEBUG && _d('About to fork and daemonize'); 3421 | defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR"; 3422 | if ( $pid ) { 3423 | PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid); 3424 | exit; 3425 | } 3426 | 3427 | PTDEBUG && _d('Daemonizing child PID', $PID); 3428 | $self->{PID_owner} = $PID; 3429 | $self->{child} = 1; 3430 | 3431 | POSIX::setsid() or die "Cannot start a new session: $OS_ERROR"; 3432 | chdir '/' or die "Cannot chdir to /: $OS_ERROR"; 3433 | 3434 | $self->_make_PID_file(); 3435 | 3436 | $OUTPUT_AUTOFLUSH = 1; 3437 | 3438 | PTDEBUG && _d('Redirecting STDIN to /dev/null'); 3439 | close STDIN; 3440 | open STDIN, '/dev/null' 3441 | or die "Cannot reopen STDIN to /dev/null: $OS_ERROR"; 3442 | 3443 | if ( $self->{log_file} ) { 3444 | PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file}); 3445 | close STDOUT; 3446 | open STDOUT, '>>', $self->{log_file} 3447 | or die "Cannot open log file $self->{log_file}: $OS_ERROR"; 3448 | 3449 | close STDERR; 3450 | open STDERR, ">&STDOUT" 3451 | or die "Cannot dupe STDERR to STDOUT: $OS_ERROR"; 3452 | } 3453 | else { 3454 | if ( -t STDOUT ) { 3455 | PTDEBUG && _d('No log file and STDOUT is a terminal;', 3456 | 'redirecting to /dev/null'); 3457 | close STDOUT; 3458 | open STDOUT, '>', '/dev/null' 3459 | or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR"; 3460 | } 3461 | if ( -t STDERR ) { 3462 | PTDEBUG && _d('No log file and STDERR is a terminal;', 3463 | 'redirecting to /dev/null'); 3464 | close STDERR; 3465 | open STDERR, '>', '/dev/null' 3466 | or die "Cannot reopen STDERR to /dev/null: $OS_ERROR"; 3467 | } 3468 | } 3469 | 3470 | return; 3471 | } 3472 | 3473 | sub check_PID_file { 3474 | my ( $self, $file ) = @_; 3475 | my $PID_file = $self ? $self->{PID_file} : $file; 3476 | PTDEBUG && _d('Checking PID file', $PID_file); 3477 | if ( $PID_file && -f $PID_file ) { 3478 | my $pid; 3479 | eval { 3480 | chomp($pid = (slurp_file($PID_file) || '')); 3481 | }; 3482 | if ( $EVAL_ERROR ) { 3483 | die "The PID file $PID_file already exists but it cannot be read: " 3484 | . $EVAL_ERROR; 3485 | } 3486 | PTDEBUG && _d('PID file exists; it contains PID', $pid); 3487 | if ( $pid ) { 3488 | my $pid_is_alive = kill 0, $pid; 3489 | if ( $pid_is_alive ) { 3490 | die "The PID file $PID_file already exists " 3491 | . " and the PID that it contains, $pid, is running"; 3492 | } 3493 | else { 3494 | warn "Overwriting PID file $PID_file because the PID that it " 3495 | . "contains, $pid, is not running"; 3496 | } 3497 | } 3498 | else { 3499 | die "The PID file $PID_file already exists but it does not " 3500 | . "contain a PID"; 3501 | } 3502 | } 3503 | else { 3504 | PTDEBUG && _d('No PID file'); 3505 | } 3506 | return; 3507 | } 3508 | 3509 | sub make_PID_file { 3510 | my ( $self ) = @_; 3511 | if ( exists $self->{child} ) { 3512 | die "Do not call Daemon::make_PID_file() for daemonized scripts"; 3513 | } 3514 | $self->_make_PID_file(); 3515 | $self->{PID_owner} = $PID; 3516 | return; 3517 | } 3518 | 3519 | sub _make_PID_file { 3520 | my ( $self ) = @_; 3521 | 3522 | my $PID_file = $self->{PID_file}; 3523 | if ( !$PID_file ) { 3524 | PTDEBUG && _d('No PID file to create'); 3525 | return; 3526 | } 3527 | 3528 | $self->check_PID_file(); 3529 | 3530 | open my $PID_FH, '>', $PID_file 3531 | or die "Cannot open PID file $PID_file: $OS_ERROR"; 3532 | print $PID_FH $PID 3533 | or die "Cannot print to PID file $PID_file: $OS_ERROR"; 3534 | close $PID_FH 3535 | or die "Cannot close PID file $PID_file: $OS_ERROR"; 3536 | 3537 | PTDEBUG && _d('Created PID file:', $self->{PID_file}); 3538 | return; 3539 | } 3540 | 3541 | sub _remove_PID_file { 3542 | my ( $self ) = @_; 3543 | if ( $self->{PID_file} && -f $self->{PID_file} ) { 3544 | unlink $self->{PID_file} 3545 | or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR"; 3546 | PTDEBUG && _d('Removed PID file'); 3547 | } 3548 | else { 3549 | PTDEBUG && _d('No PID to remove'); 3550 | } 3551 | return; 3552 | } 3553 | 3554 | sub DESTROY { 3555 | my ( $self ) = @_; 3556 | 3557 | $self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID; 3558 | 3559 | return; 3560 | } 3561 | 3562 | sub slurp_file { 3563 | my ($file) = @_; 3564 | return unless $file; 3565 | open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 3566 | return do { local $/; <$fh> }; 3567 | } 3568 | 3569 | sub _d { 3570 | my ($package, undef, $line) = caller 0; 3571 | @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 3572 | map { defined $_ ? $_ : 'undef' } 3573 | @_; 3574 | print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 3575 | } 3576 | 3577 | 1; 3578 | } 3579 | # ########################################################################### 3580 | # End Daemon package 3581 | # ########################################################################### 3582 | 3583 | # ########################################################################### 3584 | # HTTP::Micro package 3585 | # This package is a copy without comments from the original. The original 3586 | # with comments and its test file can be found in the Bazaar repository at, 3587 | # lib/HTTP/Micro.pm 3588 | # t/lib/HTTP/Micro.t 3589 | # See https://launchpad.net/percona-toolkit for more information. 3590 | # ########################################################################### 3591 | { 3592 | package HTTP::Micro; 3593 | 3594 | our $VERSION = '0.01'; 3595 | 3596 | use strict; 3597 | use warnings FATAL => 'all'; 3598 | use English qw(-no_match_vars); 3599 | use Carp (); 3600 | 3601 | my @attributes; 3602 | BEGIN { 3603 | @attributes = qw(agent timeout); 3604 | no strict 'refs'; 3605 | for my $accessor ( @attributes ) { 3606 | *{$accessor} = sub { 3607 | @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor}; 3608 | }; 3609 | } 3610 | } 3611 | 3612 | sub new { 3613 | my($class, %args) = @_; 3614 | (my $agent = $class) =~ s{::}{-}g; 3615 | my $self = { 3616 | agent => $agent . "/" . ($class->VERSION || 0), 3617 | timeout => 60, 3618 | }; 3619 | for my $key ( @attributes ) { 3620 | $self->{$key} = $args{$key} if exists $args{$key} 3621 | } 3622 | return bless $self, $class; 3623 | } 3624 | 3625 | my %DefaultPort = ( 3626 | http => 80, 3627 | https => 443, 3628 | ); 3629 | 3630 | sub request { 3631 | my ($self, $method, $url, $args) = @_; 3632 | @_ == 3 || (@_ == 4 && ref $args eq 'HASH') 3633 | or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/); 3634 | $args ||= {}; # we keep some state in this during _request 3635 | 3636 | my $response; 3637 | for ( 0 .. 1 ) { 3638 | $response = eval { $self->_request($method, $url, $args) }; 3639 | last unless $@ && $method eq 'GET' 3640 | && $@ =~ m{^(?:Socket closed|Unexpected end)}; 3641 | } 3642 | 3643 | if (my $e = "$@") { 3644 | $response = { 3645 | success => q{}, 3646 | status => 599, 3647 | reason => 'Internal Exception', 3648 | content => $e, 3649 | headers => { 3650 | 'content-type' => 'text/plain', 3651 | 'content-length' => length $e, 3652 | } 3653 | }; 3654 | } 3655 | return $response; 3656 | } 3657 | 3658 | sub _request { 3659 | my ($self, $method, $url, $args) = @_; 3660 | 3661 | my ($scheme, $host, $port, $path_query) = $self->_split_url($url); 3662 | 3663 | my $request = { 3664 | method => $method, 3665 | scheme => $scheme, 3666 | host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), 3667 | uri => $path_query, 3668 | headers => {}, 3669 | }; 3670 | 3671 | my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout}); 3672 | 3673 | $handle->connect($scheme, $host, $port); 3674 | 3675 | $self->_prepare_headers_and_cb($request, $args); 3676 | $handle->write_request_header(@{$request}{qw/method uri headers/}); 3677 | $handle->write_content_body($request) if $request->{content}; 3678 | 3679 | my $response; 3680 | do { $response = $handle->read_response_header } 3681 | until (substr($response->{status},0,1) ne '1'); 3682 | 3683 | if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) { 3684 | $response->{content} = ''; 3685 | $handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response); 3686 | } 3687 | 3688 | $handle->close; 3689 | $response->{success} = substr($response->{status},0,1) eq '2'; 3690 | return $response; 3691 | } 3692 | 3693 | sub _prepare_headers_and_cb { 3694 | my ($self, $request, $args) = @_; 3695 | 3696 | for ($args->{headers}) { 3697 | next unless defined; 3698 | while (my ($k, $v) = each %$_) { 3699 | $request->{headers}{lc $k} = $v; 3700 | } 3701 | } 3702 | $request->{headers}{'host'} = $request->{host_port}; 3703 | $request->{headers}{'connection'} = "close"; 3704 | $request->{headers}{'user-agent'} ||= $self->{agent}; 3705 | 3706 | if (defined $args->{content}) { 3707 | $request->{headers}{'content-type'} ||= "application/octet-stream"; 3708 | utf8::downgrade($args->{content}, 1) 3709 | or Carp::croak(q/Wide character in request message body/); 3710 | $request->{headers}{'content-length'} = length $args->{content}; 3711 | $request->{content} = $args->{content}; 3712 | } 3713 | return; 3714 | } 3715 | 3716 | sub _split_url { 3717 | my $url = pop; 3718 | 3719 | my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> 3720 | or Carp::croak(qq/Cannot parse URL: '$url'/); 3721 | 3722 | $scheme = lc $scheme; 3723 | $path_query = "/$path_query" unless $path_query =~ m<\A/>; 3724 | 3725 | my $host = (length($authority)) ? lc $authority : 'localhost'; 3726 | $host =~ s/\A[^@]*@//; # userinfo 3727 | my $port = do { 3728 | $host =~ s/:([0-9]*)\z// && length $1 3729 | ? $1 3730 | : $DefaultPort{$scheme} 3731 | }; 3732 | 3733 | return ($scheme, $host, $port, $path_query); 3734 | } 3735 | 3736 | } # HTTP::Micro 3737 | 3738 | { 3739 | package HTTP::Micro::Handle; 3740 | 3741 | use strict; 3742 | use warnings FATAL => 'all'; 3743 | use English qw(-no_match_vars); 3744 | 3745 | use Carp qw(croak); 3746 | use Errno qw(EINTR EPIPE); 3747 | use IO::Socket qw(SOCK_STREAM); 3748 | 3749 | sub BUFSIZE () { 32768 } 3750 | 3751 | my $Printable = sub { 3752 | local $_ = shift; 3753 | s/\r/\\r/g; 3754 | s/\n/\\n/g; 3755 | s/\t/\\t/g; 3756 | s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; 3757 | $_; 3758 | }; 3759 | 3760 | sub new { 3761 | my ($class, %args) = @_; 3762 | return bless { 3763 | rbuf => '', 3764 | timeout => 60, 3765 | max_line_size => 16384, 3766 | %args 3767 | }, $class; 3768 | } 3769 | 3770 | my $ssl_verify_args = { 3771 | check_cn => "when_only", 3772 | wildcards_in_alt => "anywhere", 3773 | wildcards_in_cn => "anywhere" 3774 | }; 3775 | 3776 | sub connect { 3777 | @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); 3778 | my ($self, $scheme, $host, $port) = @_; 3779 | 3780 | if ( $scheme eq 'https' ) { 3781 | eval "require IO::Socket::SSL" 3782 | unless exists $INC{'IO/Socket/SSL.pm'}; 3783 | croak(qq/IO::Socket::SSL must be installed for https support\n/) 3784 | unless $INC{'IO/Socket/SSL.pm'}; 3785 | } 3786 | elsif ( $scheme ne 'http' ) { 3787 | croak(qq/Unsupported URL scheme '$scheme'\n/); 3788 | } 3789 | 3790 | $self->{fh} = IO::Socket::INET->new( 3791 | PeerHost => $host, 3792 | PeerPort => $port, 3793 | Proto => 'tcp', 3794 | Type => SOCK_STREAM, 3795 | Timeout => $self->{timeout} 3796 | ) or croak(qq/Could not connect to '$host:$port': $@/); 3797 | 3798 | binmode($self->{fh}) 3799 | or croak(qq/Could not binmode() socket: '$!'/); 3800 | 3801 | if ( $scheme eq 'https') { 3802 | IO::Socket::SSL->start_SSL($self->{fh}); 3803 | ref($self->{fh}) eq 'IO::Socket::SSL' 3804 | or die(qq/SSL connection failed for $host\n/); 3805 | if ( $self->{fh}->can("verify_hostname") ) { 3806 | $self->{fh}->verify_hostname( $host, $ssl_verify_args ) 3807 | or die(qq/SSL certificate not valid for $host\n/); 3808 | } 3809 | else { 3810 | my $fh = $self->{fh}; 3811 | _verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args) 3812 | or die(qq/SSL certificate not valid for $host\n/); 3813 | } 3814 | } 3815 | 3816 | $self->{host} = $host; 3817 | $self->{port} = $port; 3818 | 3819 | return $self; 3820 | } 3821 | 3822 | sub close { 3823 | @_ == 1 || croak(q/Usage: $handle->close()/); 3824 | my ($self) = @_; 3825 | CORE::close($self->{fh}) 3826 | or croak(qq/Could not close socket: '$!'/); 3827 | } 3828 | 3829 | sub write { 3830 | @_ == 2 || croak(q/Usage: $handle->write(buf)/); 3831 | my ($self, $buf) = @_; 3832 | 3833 | my $len = length $buf; 3834 | my $off = 0; 3835 | 3836 | local $SIG{PIPE} = 'IGNORE'; 3837 | 3838 | while () { 3839 | $self->can_write 3840 | or croak(q/Timed out while waiting for socket to become ready for writing/); 3841 | my $r = syswrite($self->{fh}, $buf, $len, $off); 3842 | if (defined $r) { 3843 | $len -= $r; 3844 | $off += $r; 3845 | last unless $len > 0; 3846 | } 3847 | elsif ($! == EPIPE) { 3848 | croak(qq/Socket closed by remote server: $!/); 3849 | } 3850 | elsif ($! != EINTR) { 3851 | croak(qq/Could not write to socket: '$!'/); 3852 | } 3853 | } 3854 | return $off; 3855 | } 3856 | 3857 | sub read { 3858 | @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/); 3859 | my ($self, $len) = @_; 3860 | 3861 | my $buf = ''; 3862 | my $got = length $self->{rbuf}; 3863 | 3864 | if ($got) { 3865 | my $take = ($got < $len) ? $got : $len; 3866 | $buf = substr($self->{rbuf}, 0, $take, ''); 3867 | $len -= $take; 3868 | } 3869 | 3870 | while ($len > 0) { 3871 | $self->can_read 3872 | or croak(q/Timed out while waiting for socket to become ready for reading/); 3873 | my $r = sysread($self->{fh}, $buf, $len, length $buf); 3874 | if (defined $r) { 3875 | last unless $r; 3876 | $len -= $r; 3877 | } 3878 | elsif ($! != EINTR) { 3879 | croak(qq/Could not read from socket: '$!'/); 3880 | } 3881 | } 3882 | if ($len) { 3883 | croak(q/Unexpected end of stream/); 3884 | } 3885 | return $buf; 3886 | } 3887 | 3888 | sub readline { 3889 | @_ == 1 || croak(q/Usage: $handle->readline()/); 3890 | my ($self) = @_; 3891 | 3892 | while () { 3893 | if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { 3894 | return $1; 3895 | } 3896 | $self->can_read 3897 | or croak(q/Timed out while waiting for socket to become ready for reading/); 3898 | my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); 3899 | if (defined $r) { 3900 | last unless $r; 3901 | } 3902 | elsif ($! != EINTR) { 3903 | croak(qq/Could not read from socket: '$!'/); 3904 | } 3905 | } 3906 | croak(q/Unexpected end of stream while looking for line/); 3907 | } 3908 | 3909 | sub read_header_lines { 3910 | @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); 3911 | my ($self, $headers) = @_; 3912 | $headers ||= {}; 3913 | my $lines = 0; 3914 | my $val; 3915 | 3916 | while () { 3917 | my $line = $self->readline; 3918 | 3919 | if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { 3920 | my ($field_name) = lc $1; 3921 | $val = \($headers->{$field_name} = $2); 3922 | } 3923 | elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { 3924 | $val 3925 | or croak(q/Unexpected header continuation line/); 3926 | next unless length $1; 3927 | $$val .= ' ' if length $$val; 3928 | $$val .= $1; 3929 | } 3930 | elsif ($line =~ /\A \x0D?\x0A \z/x) { 3931 | last; 3932 | } 3933 | else { 3934 | croak(q/Malformed header line: / . $Printable->($line)); 3935 | } 3936 | } 3937 | return $headers; 3938 | } 3939 | 3940 | sub write_header_lines { 3941 | (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); 3942 | my($self, $headers) = @_; 3943 | 3944 | my $buf = ''; 3945 | while (my ($k, $v) = each %$headers) { 3946 | my $field_name = lc $k; 3947 | $field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x 3948 | or croak(q/Invalid HTTP header field name: / . $Printable->($field_name)); 3949 | $field_name =~ s/\b(\w)/\u$1/g; 3950 | $buf .= "$field_name: $v\x0D\x0A"; 3951 | } 3952 | $buf .= "\x0D\x0A"; 3953 | return $self->write($buf); 3954 | } 3955 | 3956 | sub read_content_body { 3957 | @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); 3958 | my ($self, $cb, $response, $len) = @_; 3959 | $len ||= $response->{headers}{'content-length'}; 3960 | 3961 | croak("No content-length in the returned response, and this " 3962 | . "UA doesn't implement chunking") unless defined $len; 3963 | 3964 | while ($len > 0) { 3965 | my $read = ($len > BUFSIZE) ? BUFSIZE : $len; 3966 | $cb->($self->read($read), $response); 3967 | $len -= $read; 3968 | } 3969 | 3970 | return; 3971 | } 3972 | 3973 | sub write_content_body { 3974 | @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/); 3975 | my ($self, $request) = @_; 3976 | my ($len, $content_length) = (0, $request->{headers}{'content-length'}); 3977 | 3978 | $len += $self->write($request->{content}); 3979 | 3980 | $len == $content_length 3981 | or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); 3982 | 3983 | return $len; 3984 | } 3985 | 3986 | sub read_response_header { 3987 | @_ == 1 || croak(q/Usage: $handle->read_response_header()/); 3988 | my ($self) = @_; 3989 | 3990 | my $line = $self->readline; 3991 | 3992 | $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x 3993 | or croak(q/Malformed Status-Line: / . $Printable->($line)); 3994 | 3995 | my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); 3996 | 3997 | return { 3998 | status => $status, 3999 | reason => $reason, 4000 | headers => $self->read_header_lines, 4001 | protocol => $protocol, 4002 | }; 4003 | } 4004 | 4005 | sub write_request_header { 4006 | @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/); 4007 | my ($self, $method, $request_uri, $headers) = @_; 4008 | 4009 | return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") 4010 | + $self->write_header_lines($headers); 4011 | } 4012 | 4013 | sub _do_timeout { 4014 | my ($self, $type, $timeout) = @_; 4015 | $timeout = $self->{timeout} 4016 | unless defined $timeout && $timeout >= 0; 4017 | 4018 | my $fd = fileno $self->{fh}; 4019 | defined $fd && $fd >= 0 4020 | or croak(q/select(2): 'Bad file descriptor'/); 4021 | 4022 | my $initial = time; 4023 | my $pending = $timeout; 4024 | my $nfound; 4025 | 4026 | vec(my $fdset = '', $fd, 1) = 1; 4027 | 4028 | while () { 4029 | $nfound = ($type eq 'read') 4030 | ? select($fdset, undef, undef, $pending) 4031 | : select(undef, $fdset, undef, $pending) ; 4032 | if ($nfound == -1) { 4033 | $! == EINTR 4034 | or croak(qq/select(2): '$!'/); 4035 | redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; 4036 | $nfound = 0; 4037 | } 4038 | last; 4039 | } 4040 | $! = 0; 4041 | return $nfound; 4042 | } 4043 | 4044 | sub can_read { 4045 | @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/); 4046 | my $self = shift; 4047 | return $self->_do_timeout('read', @_) 4048 | } 4049 | 4050 | sub can_write { 4051 | @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/); 4052 | my $self = shift; 4053 | return $self->_do_timeout('write', @_) 4054 | } 4055 | } # HTTP::Micro::Handle 4056 | 4057 | my $prog = <<'EOP'; 4058 | BEGIN { 4059 | if ( defined &IO::Socket::SSL::CAN_IPV6 ) { 4060 | *CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6; 4061 | } 4062 | else { 4063 | constant->import( CAN_IPV6 => '' ); 4064 | } 4065 | my %const = ( 4066 | NID_CommonName => 13, 4067 | GEN_DNS => 2, 4068 | GEN_IPADD => 7, 4069 | ); 4070 | while ( my ($name,$value) = each %const ) { 4071 | no strict 'refs'; 4072 | *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value }; 4073 | } 4074 | } 4075 | { 4076 | use Carp qw(croak); 4077 | my %dispatcher = ( 4078 | issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) }, 4079 | subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) }, 4080 | ); 4081 | if ( $Net::SSLeay::VERSION >= 1.30 ) { 4082 | $dispatcher{commonName} = sub { 4083 | my $cn = Net::SSLeay::X509_NAME_get_text_by_NID( 4084 | Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName); 4085 | $cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33 4086 | $cn; 4087 | } 4088 | } else { 4089 | $dispatcher{commonName} = sub { 4090 | croak "you need at least Net::SSLeay version 1.30 for getting commonName" 4091 | } 4092 | } 4093 | 4094 | if ( $Net::SSLeay::VERSION >= 1.33 ) { 4095 | $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; 4096 | } else { 4097 | $dispatcher{subjectAltNames} = sub { 4098 | return; 4099 | }; 4100 | } 4101 | 4102 | $dispatcher{authority} = $dispatcher{issuer}; 4103 | $dispatcher{owner} = $dispatcher{subject}; 4104 | $dispatcher{cn} = $dispatcher{commonName}; 4105 | 4106 | sub _peer_certificate { 4107 | my ($self, $field) = @_; 4108 | my $ssl = $self->_get_ssl_object or return; 4109 | 4110 | my $cert = ${*$self}{_SSL_certificate} 4111 | ||= Net::SSLeay::get_peer_certificate($ssl) 4112 | or return $self->error("Could not retrieve peer certificate"); 4113 | 4114 | if ($field) { 4115 | my $sub = $dispatcher{$field} or croak 4116 | "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ). 4117 | "\nMaybe you need to upgrade your Net::SSLeay"; 4118 | return $sub->($cert); 4119 | } else { 4120 | return $cert 4121 | } 4122 | } 4123 | 4124 | 4125 | my %scheme = ( 4126 | ldap => { 4127 | wildcards_in_cn => 0, 4128 | wildcards_in_alt => 'leftmost', 4129 | check_cn => 'always', 4130 | }, 4131 | http => { 4132 | wildcards_in_cn => 'anywhere', 4133 | wildcards_in_alt => 'anywhere', 4134 | check_cn => 'when_only', 4135 | }, 4136 | smtp => { 4137 | wildcards_in_cn => 0, 4138 | wildcards_in_alt => 0, 4139 | check_cn => 'always' 4140 | }, 4141 | none => {}, # do not check 4142 | ); 4143 | 4144 | $scheme{www} = $scheme{http}; # alias 4145 | $scheme{xmpp} = $scheme{http}; # rfc 3920 4146 | $scheme{pop3} = $scheme{ldap}; # rfc 2595 4147 | $scheme{imap} = $scheme{ldap}; # rfc 2595 4148 | $scheme{acap} = $scheme{ldap}; # rfc 2595 4149 | $scheme{nntp} = $scheme{ldap}; # rfc 4642 4150 | $scheme{ftp} = $scheme{http}; # rfc 4217 4151 | 4152 | 4153 | sub _verify_hostname_of_cert { 4154 | my $identity = shift; 4155 | my $cert = shift; 4156 | my $scheme = shift || 'none'; 4157 | if ( ! ref($scheme) ) { 4158 | $scheme = $scheme{$scheme} or croak "scheme $scheme not defined"; 4159 | } 4160 | 4161 | return 1 if ! %$scheme; # 'none' 4162 | 4163 | my $commonName = $dispatcher{cn}->($cert); 4164 | my @altNames = $dispatcher{subjectAltNames}->($cert); 4165 | 4166 | if ( my $sub = $scheme->{callback} ) { 4167 | return $sub->($identity,$commonName,@altNames); 4168 | } 4169 | 4170 | 4171 | my $ipn; 4172 | if ( CAN_IPV6 and $identity =~m{:} ) { 4173 | $ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity) 4174 | or croak "'$identity' is not IPv6, but neither IPv4 nor hostname"; 4175 | } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) { 4176 | $ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; 4177 | } else { 4178 | if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) { 4179 | $identity =~m{\0} and croak("name '$identity' has \\0 byte"); 4180 | $identity = IO::Socket::SSL::idn_to_ascii($identity) or 4181 | croak "Warning: Given name '$identity' could not be converted to IDNA!"; 4182 | } 4183 | } 4184 | 4185 | my $check_name = sub { 4186 | my ($name,$identity,$wtyp) = @_; 4187 | $wtyp ||= ''; 4188 | my $pattern; 4189 | if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) { 4190 | $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i; 4191 | } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) { 4192 | $pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i; 4193 | } else { 4194 | $pattern = qr{^\Q$name\E$}i; 4195 | } 4196 | return $identity =~ $pattern; 4197 | }; 4198 | 4199 | my $alt_dnsNames = 0; 4200 | while (@altNames) { 4201 | my ($type, $name) = splice (@altNames, 0, 2); 4202 | if ( $ipn and $type == GEN_IPADD ) { 4203 | return 1 if $ipn eq $name; 4204 | 4205 | } elsif ( ! $ipn and $type == GEN_DNS ) { 4206 | $name =~s/\s+$//; $name =~s/^\s+//; 4207 | $alt_dnsNames++; 4208 | $check_name->($name,$identity,$scheme->{wildcards_in_alt}) 4209 | and return 1; 4210 | } 4211 | } 4212 | 4213 | if ( ! $ipn and ( 4214 | $scheme->{check_cn} eq 'always' or 4215 | $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) { 4216 | $check_name->($commonName,$identity,$scheme->{wildcards_in_cn}) 4217 | and return 1; 4218 | } 4219 | 4220 | return 0; # no match 4221 | } 4222 | } 4223 | EOP 4224 | 4225 | eval { require IO::Socket::SSL }; 4226 | if ( $INC{"IO/Socket/SSL.pm"} ) { 4227 | eval $prog; 4228 | die $@ if $@; 4229 | } 4230 | 4231 | 1; 4232 | # ########################################################################### 4233 | # End HTTP::Micro package 4234 | # ########################################################################### 4235 | 4236 | # ########################################################################### 4237 | # VersionCheck package 4238 | # This package is a copy without comments from the original. The original 4239 | # with comments and its test file can be found in the Bazaar repository at, 4240 | # lib/VersionCheck.pm 4241 | # t/lib/VersionCheck.t 4242 | # See https://launchpad.net/percona-toolkit for more information. 4243 | # ########################################################################### 4244 | { 4245 | package VersionCheck; 4246 | 4247 | 4248 | use strict; 4249 | use warnings FATAL => 'all'; 4250 | use English qw(-no_match_vars); 4251 | 4252 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 4253 | 4254 | use Data::Dumper; 4255 | local $Data::Dumper::Indent = 1; 4256 | local $Data::Dumper::Sortkeys = 1; 4257 | local $Data::Dumper::Quotekeys = 0; 4258 | 4259 | use Digest::MD5 qw(md5_hex); 4260 | use Sys::Hostname qw(hostname); 4261 | use File::Basename qw(); 4262 | use File::Spec; 4263 | use FindBin qw(); 4264 | 4265 | eval { 4266 | require Percona::Toolkit; 4267 | require HTTP::Micro; 4268 | }; 4269 | 4270 | { 4271 | my $file = 'percona-version-check'; 4272 | my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.'; 4273 | my @vc_dirs = ( 4274 | '/etc/percona', 4275 | '/etc/percona-toolkit', 4276 | '/tmp', 4277 | "$home", 4278 | ); 4279 | 4280 | sub version_check_file { 4281 | foreach my $dir ( @vc_dirs ) { 4282 | if ( -d $dir && -w $dir ) { 4283 | PTDEBUG && _d('Version check file', $file, 'in', $dir); 4284 | return $dir . '/' . $file; 4285 | } 4286 | } 4287 | PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD}); 4288 | return $file; # in the CWD 4289 | } 4290 | } 4291 | 4292 | sub version_check_time_limit { 4293 | return 60 * 60 * 24; # one day 4294 | } 4295 | 4296 | 4297 | sub version_check { 4298 | my (%args) = @_; 4299 | 4300 | my $instances = $args{instances} || []; 4301 | my $instances_to_check; 4302 | 4303 | PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin); 4304 | if ( !$args{force} ) { 4305 | if ( $FindBin::Bin 4306 | && (-d "$FindBin::Bin/../.bzr" || 4307 | -d "$FindBin::Bin/../../.bzr" || 4308 | -d "$FindBin::Bin/../.git" || 4309 | -d "$FindBin::Bin/../../.git" 4310 | ) 4311 | ) { 4312 | PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check"); 4313 | return; 4314 | } 4315 | } 4316 | 4317 | eval { 4318 | foreach my $instance ( @$instances ) { 4319 | my ($name, $id) = get_instance_id($instance); 4320 | $instance->{name} = $name; 4321 | $instance->{id} = $id; 4322 | } 4323 | 4324 | push @$instances, { name => 'system', id => 0 }; 4325 | 4326 | $instances_to_check = get_instances_to_check( 4327 | instances => $instances, 4328 | vc_file => $args{vc_file}, # testing 4329 | now => $args{now}, # testing 4330 | ); 4331 | PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); 4332 | return unless @$instances_to_check; 4333 | 4334 | my $protocol = 'https'; 4335 | eval { require IO::Socket::SSL; }; 4336 | if ( $EVAL_ERROR ) { 4337 | PTDEBUG && _d($EVAL_ERROR); 4338 | PTDEBUG && _d("SSL not available, won't run version_check"); 4339 | return; 4340 | } 4341 | PTDEBUG && _d('Using', $protocol); 4342 | 4343 | my $advice = pingback( 4344 | instances => $instances_to_check, 4345 | protocol => $protocol, 4346 | url => $args{url} # testing 4347 | || $ENV{PERCONA_VERSION_CHECK_URL} # testing 4348 | || "$protocol://v.percona.com", 4349 | ); 4350 | if ( $advice ) { 4351 | PTDEBUG && _d('Advice:', Dumper($advice)); 4352 | if ( scalar @$advice > 1) { 4353 | print "\n# " . scalar @$advice . " software updates are " 4354 | . "available:\n"; 4355 | } 4356 | else { 4357 | print "\n# A software update is available:\n"; 4358 | } 4359 | print join("\n", map { "# * $_" } @$advice), "\n\n"; 4360 | } 4361 | }; 4362 | if ( $EVAL_ERROR ) { 4363 | PTDEBUG && _d('Version check failed:', $EVAL_ERROR); 4364 | } 4365 | 4366 | if ( @$instances_to_check ) { 4367 | eval { 4368 | update_check_times( 4369 | instances => $instances_to_check, 4370 | vc_file => $args{vc_file}, # testing 4371 | now => $args{now}, # testing 4372 | ); 4373 | }; 4374 | if ( $EVAL_ERROR ) { 4375 | PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR); 4376 | } 4377 | } 4378 | 4379 | if ( $ENV{PTDEBUG_VERSION_CHECK} ) { 4380 | warn "Exiting because the PTDEBUG_VERSION_CHECK " 4381 | . "environment variable is defined.\n"; 4382 | exit 255; 4383 | } 4384 | 4385 | return; 4386 | } 4387 | 4388 | sub get_instances_to_check { 4389 | my (%args) = @_; 4390 | 4391 | my $instances = $args{instances}; 4392 | my $now = $args{now} || int(time); 4393 | my $vc_file = $args{vc_file} || version_check_file(); 4394 | 4395 | if ( !-f $vc_file ) { 4396 | PTDEBUG && _d('Version check file', $vc_file, 'does not exist;', 4397 | 'version checking all instances'); 4398 | return $instances; 4399 | } 4400 | 4401 | open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; 4402 | chomp(my $file_contents = do { local $/ = undef; <$fh> }); 4403 | PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents); 4404 | close $fh; 4405 | my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; 4406 | 4407 | my $check_time_limit = version_check_time_limit(); 4408 | my @instances_to_check; 4409 | foreach my $instance ( @$instances ) { 4410 | my $last_check_time = $last_check_time_for{ $instance->{id} }; 4411 | PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', 4412 | $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0), 4413 | 'hours until next check', 4414 | sprintf '%.2f', 4415 | ($check_time_limit - ($now - ($last_check_time || 0))) / 3600); 4416 | if ( !defined $last_check_time 4417 | || ($now - $last_check_time) >= $check_time_limit ) { 4418 | PTDEBUG && _d('Time to check', Dumper($instance)); 4419 | push @instances_to_check, $instance; 4420 | } 4421 | } 4422 | 4423 | return \@instances_to_check; 4424 | } 4425 | 4426 | sub update_check_times { 4427 | my (%args) = @_; 4428 | 4429 | my $instances = $args{instances}; 4430 | my $now = $args{now} || int(time); 4431 | my $vc_file = $args{vc_file} || version_check_file(); 4432 | PTDEBUG && _d('Updating last check time:', $now); 4433 | 4434 | my %all_instances = map { 4435 | $_->{id} => { name => $_->{name}, ts => $now } 4436 | } @$instances; 4437 | 4438 | if ( -f $vc_file ) { 4439 | open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR"; 4440 | my $contents = do { local $/ = undef; <$fh> }; 4441 | close $fh; 4442 | 4443 | foreach my $line ( split("\n", ($contents || '')) ) { 4444 | my ($id, $ts) = split(',', $line); 4445 | if ( !exists $all_instances{$id} ) { 4446 | $all_instances{$id} = { ts => $ts }; # original ts, not updated 4447 | } 4448 | } 4449 | } 4450 | 4451 | open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; 4452 | foreach my $id ( sort keys %all_instances ) { 4453 | PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id})); 4454 | print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n"; 4455 | } 4456 | close $fh; 4457 | 4458 | return; 4459 | } 4460 | 4461 | sub get_instance_id { 4462 | my ($instance) = @_; 4463 | 4464 | my $dbh = $instance->{dbh}; 4465 | my $dsn = $instance->{dsn}; 4466 | 4467 | my $sql = q{SELECT CONCAT(@@hostname, @@port)}; 4468 | PTDEBUG && _d($sql); 4469 | my ($name) = eval { $dbh->selectrow_array($sql) }; 4470 | if ( $EVAL_ERROR ) { 4471 | PTDEBUG && _d($EVAL_ERROR); 4472 | $sql = q{SELECT @@hostname}; 4473 | PTDEBUG && _d($sql); 4474 | ($name) = eval { $dbh->selectrow_array($sql) }; 4475 | if ( $EVAL_ERROR ) { 4476 | PTDEBUG && _d($EVAL_ERROR); 4477 | $name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306); 4478 | } 4479 | else { 4480 | $sql = q{SHOW VARIABLES LIKE 'port'}; 4481 | PTDEBUG && _d($sql); 4482 | my (undef, $port) = eval { $dbh->selectrow_array($sql) }; 4483 | PTDEBUG && _d('port:', $port); 4484 | $name .= $port || ''; 4485 | } 4486 | } 4487 | my $id = md5_hex($name); 4488 | 4489 | PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn)); 4490 | 4491 | return $name, $id; 4492 | } 4493 | 4494 | 4495 | sub pingback { 4496 | my (%args) = @_; 4497 | my @required_args = qw(url instances); 4498 | foreach my $arg ( @required_args ) { 4499 | die "I need a $arg arugment" unless $args{$arg}; 4500 | } 4501 | my $url = $args{url}; 4502 | my $instances = $args{instances}; 4503 | 4504 | my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 ); 4505 | 4506 | my $response = $ua->request('GET', $url); 4507 | PTDEBUG && _d('Server response:', Dumper($response)); 4508 | die "No response from GET $url" 4509 | if !$response; 4510 | die("GET on $url returned HTTP status $response->{status}; expected 200\n", 4511 | ($response->{content} || '')) if $response->{status} != 200; 4512 | die("GET on $url did not return any programs to check") 4513 | if !$response->{content}; 4514 | 4515 | my $items = parse_server_response( 4516 | response => $response->{content} 4517 | ); 4518 | die "Failed to parse server requested programs: $response->{content}" 4519 | if !scalar keys %$items; 4520 | 4521 | my $versions = get_versions( 4522 | items => $items, 4523 | instances => $instances, 4524 | ); 4525 | die "Failed to get any program versions; should have at least gotten Perl" 4526 | if !scalar keys %$versions; 4527 | 4528 | my $client_content = encode_client_response( 4529 | items => $items, 4530 | versions => $versions, 4531 | general_id => md5_hex( hostname() ), 4532 | ); 4533 | 4534 | my $client_response = { 4535 | headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, 4536 | content => $client_content, 4537 | }; 4538 | PTDEBUG && _d('Client response:', Dumper($client_response)); 4539 | 4540 | $response = $ua->request('POST', $url, $client_response); 4541 | PTDEBUG && _d('Server suggestions:', Dumper($response)); 4542 | die "No response from POST $url $client_response" 4543 | if !$response; 4544 | die "POST $url returned HTTP status $response->{status}; expected 200" 4545 | if $response->{status} != 200; 4546 | 4547 | return unless $response->{content}; 4548 | 4549 | $items = parse_server_response( 4550 | response => $response->{content}, 4551 | split_vars => 0, 4552 | ); 4553 | die "Failed to parse server suggestions: $response->{content}" 4554 | if !scalar keys %$items; 4555 | my @suggestions = map { $_->{vars} } 4556 | sort { $a->{item} cmp $b->{item} } 4557 | values %$items; 4558 | 4559 | return \@suggestions; 4560 | } 4561 | 4562 | sub encode_client_response { 4563 | my (%args) = @_; 4564 | my @required_args = qw(items versions general_id); 4565 | foreach my $arg ( @required_args ) { 4566 | die "I need a $arg arugment" unless $args{$arg}; 4567 | } 4568 | my ($items, $versions, $general_id) = @args{@required_args}; 4569 | 4570 | my @lines; 4571 | foreach my $item ( sort keys %$items ) { 4572 | next unless exists $versions->{$item}; 4573 | if ( ref($versions->{$item}) eq 'HASH' ) { 4574 | my $mysql_versions = $versions->{$item}; 4575 | for my $id ( sort keys %$mysql_versions ) { 4576 | push @lines, join(';', $id, $item, $mysql_versions->{$id}); 4577 | } 4578 | } 4579 | else { 4580 | push @lines, join(';', $general_id, $item, $versions->{$item}); 4581 | } 4582 | } 4583 | 4584 | my $client_response = join("\n", @lines) . "\n"; 4585 | return $client_response; 4586 | } 4587 | 4588 | sub parse_server_response { 4589 | my (%args) = @_; 4590 | my @required_args = qw(response); 4591 | foreach my $arg ( @required_args ) { 4592 | die "I need a $arg arugment" unless $args{$arg}; 4593 | } 4594 | my ($response) = @args{@required_args}; 4595 | 4596 | my %items = map { 4597 | my ($item, $type, $vars) = split(";", $_); 4598 | if ( !defined $args{split_vars} || $args{split_vars} ) { 4599 | $vars = [ split(",", ($vars || '')) ]; 4600 | } 4601 | $item => { 4602 | item => $item, 4603 | type => $type, 4604 | vars => $vars, 4605 | }; 4606 | } split("\n", $response); 4607 | 4608 | PTDEBUG && _d('Items:', Dumper(\%items)); 4609 | 4610 | return \%items; 4611 | } 4612 | 4613 | my %sub_for_type = ( 4614 | os_version => \&get_os_version, 4615 | perl_version => \&get_perl_version, 4616 | perl_module_version => \&get_perl_module_version, 4617 | mysql_variable => \&get_mysql_variable, 4618 | ); 4619 | 4620 | sub valid_item { 4621 | my ($item) = @_; 4622 | return unless $item; 4623 | if ( !exists $sub_for_type{ $item->{type} } ) { 4624 | PTDEBUG && _d('Invalid type:', $item->{type}); 4625 | return 0; 4626 | } 4627 | return 1; 4628 | } 4629 | 4630 | sub get_versions { 4631 | my (%args) = @_; 4632 | my @required_args = qw(items); 4633 | foreach my $arg ( @required_args ) { 4634 | die "I need a $arg arugment" unless $args{$arg}; 4635 | } 4636 | my ($items) = @args{@required_args}; 4637 | 4638 | my %versions; 4639 | foreach my $item ( values %$items ) { 4640 | next unless valid_item($item); 4641 | eval { 4642 | my $version = $sub_for_type{ $item->{type} }->( 4643 | item => $item, 4644 | instances => $args{instances}, 4645 | ); 4646 | if ( $version ) { 4647 | chomp $version unless ref($version); 4648 | $versions{$item->{item}} = $version; 4649 | } 4650 | }; 4651 | if ( $EVAL_ERROR ) { 4652 | PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR); 4653 | } 4654 | } 4655 | 4656 | return \%versions; 4657 | } 4658 | 4659 | 4660 | sub get_os_version { 4661 | if ( $OSNAME eq 'MSWin32' ) { 4662 | require Win32; 4663 | return Win32::GetOSDisplayName(); 4664 | } 4665 | 4666 | chomp(my $platform = `uname -s`); 4667 | PTDEBUG && _d('platform:', $platform); 4668 | return $OSNAME unless $platform; 4669 | 4670 | chomp(my $lsb_release 4671 | = `which lsb_release 2>/dev/null | awk '{print \$1}'` || ''); 4672 | PTDEBUG && _d('lsb_release:', $lsb_release); 4673 | 4674 | my $release = ""; 4675 | 4676 | if ( $platform eq 'Linux' ) { 4677 | if ( -f "/etc/fedora-release" ) { 4678 | $release = `cat /etc/fedora-release`; 4679 | } 4680 | elsif ( -f "/etc/redhat-release" ) { 4681 | $release = `cat /etc/redhat-release`; 4682 | } 4683 | elsif ( -f "/etc/system-release" ) { 4684 | $release = `cat /etc/system-release`; 4685 | } 4686 | elsif ( $lsb_release ) { 4687 | $release = `$lsb_release -ds`; 4688 | } 4689 | elsif ( -f "/etc/lsb-release" ) { 4690 | $release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`; 4691 | $release =~ s/^\w+="([^"]+)".+/$1/; 4692 | } 4693 | elsif ( -f "/etc/debian_version" ) { 4694 | chomp(my $rel = `cat /etc/debian_version`); 4695 | $release = "Debian $rel"; 4696 | if ( -f "/etc/apt/sources.list" ) { 4697 | 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}'`); 4698 | $release .= " ($code_name)" if $code_name; 4699 | } 4700 | } 4701 | elsif ( -f "/etc/os-release" ) { # openSUSE 4702 | chomp($release = `grep PRETTY_NAME /etc/os-release`); 4703 | $release =~ s/^PRETTY_NAME="(.+)"$/$1/; 4704 | } 4705 | elsif ( `ls /etc/*release 2>/dev/null` ) { 4706 | if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) { 4707 | $release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`; 4708 | } 4709 | else { 4710 | $release = `cat /etc/*release | head -n1`; 4711 | } 4712 | } 4713 | } 4714 | elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) { 4715 | my $rel = `uname -r`; 4716 | $release = "$platform $rel"; 4717 | } 4718 | elsif ( $platform eq "SunOS" ) { 4719 | my $rel = `head -n1 /etc/release` || `uname -r`; 4720 | $release = "$platform $rel"; 4721 | } 4722 | 4723 | if ( !$release ) { 4724 | PTDEBUG && _d('Failed to get the release, using platform'); 4725 | $release = $platform; 4726 | } 4727 | chomp($release); 4728 | 4729 | $release =~ s/^"|"$//g; 4730 | 4731 | PTDEBUG && _d('OS version =', $release); 4732 | return $release; 4733 | } 4734 | 4735 | sub get_perl_version { 4736 | my (%args) = @_; 4737 | my $item = $args{item}; 4738 | return unless $item; 4739 | 4740 | my $version = sprintf '%vd', $PERL_VERSION; 4741 | PTDEBUG && _d('Perl version', $version); 4742 | return $version; 4743 | } 4744 | 4745 | sub get_perl_module_version { 4746 | my (%args) = @_; 4747 | my $item = $args{item}; 4748 | return unless $item; 4749 | 4750 | my $var = '$' . $item->{item} . '::VERSION'; 4751 | my $version = eval "use $item->{item}; $var;"; 4752 | PTDEBUG && _d('Perl version for', $var, '=', $version); 4753 | return $version; 4754 | } 4755 | 4756 | sub get_mysql_variable { 4757 | return get_from_mysql( 4758 | show => 'VARIABLES', 4759 | @_, 4760 | ); 4761 | } 4762 | 4763 | sub get_from_mysql { 4764 | my (%args) = @_; 4765 | my $show = $args{show}; 4766 | my $item = $args{item}; 4767 | my $instances = $args{instances}; 4768 | return unless $show && $item; 4769 | 4770 | if ( !$instances || !@$instances ) { 4771 | PTDEBUG && _d('Cannot check', $item, 4772 | 'because there are no MySQL instances'); 4773 | return; 4774 | } 4775 | 4776 | if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') { 4777 | @{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}}; 4778 | } 4779 | 4780 | 4781 | my @versions; 4782 | my %version_for; 4783 | foreach my $instance ( @$instances ) { 4784 | next unless $instance->{id}; # special system instance has id=0 4785 | my $dbh = $instance->{dbh}; 4786 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; 4787 | my $sql = qq/SHOW $show/; 4788 | PTDEBUG && _d($sql); 4789 | my $rows = $dbh->selectall_hashref($sql, 'variable_name'); 4790 | 4791 | my @versions; 4792 | foreach my $var ( @{$item->{vars}} ) { 4793 | $var = lc($var); 4794 | my $version = $rows->{$var}->{value}; 4795 | PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version, 4796 | 'on', $instance->{name}); 4797 | push @versions, $version; 4798 | } 4799 | $version_for{ $instance->{id} } = join(' ', @versions); 4800 | } 4801 | 4802 | return \%version_for; 4803 | } 4804 | 4805 | sub _d { 4806 | my ($package, undef, $line) = caller 0; 4807 | @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 4808 | map { defined $_ ? $_ : 'undef' } 4809 | @_; 4810 | print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 4811 | } 4812 | 4813 | 1; 4814 | } 4815 | # ########################################################################### 4816 | # End VersionCheck package 4817 | # ########################################################################### 4818 | 4819 | # ########################################################################### 4820 | # This is a combination of modules and programs in one -- a runnable module. 4821 | # http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last 4822 | # Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition. 4823 | # 4824 | # Check at the end of this package for the call to main() which actually runs 4825 | # the program. 4826 | # ########################################################################### 4827 | package pt_slave_restart; 4828 | 4829 | use English qw(-no_match_vars); 4830 | use IO::File; 4831 | use List::Util qw(min max); 4832 | use Time::HiRes qw(sleep); 4833 | use sigtrap qw(handler finish untrapped normal-signals); 4834 | 4835 | use Percona::Toolkit; 4836 | use constant PTDEBUG => $ENV{PTDEBUG} || 0; 4837 | 4838 | use Data::Dumper; 4839 | 4840 | local $Data::Dumper::Indent = 1; 4841 | local $Data::Dumper::Sortkeys = 1; 4842 | local $Data::Dumper::Quotekeys = 0; 4843 | 4844 | $OUTPUT_AUTOFLUSH = 1; 4845 | 4846 | my $o; 4847 | my $dp; 4848 | my $q = new Quoter(); 4849 | my %children; 4850 | 4851 | sub main { 4852 | local @ARGV = @_; # set global ARGV for this package 4853 | 4854 | # ######################################################################## 4855 | # Get configuration information. 4856 | # ######################################################################## 4857 | $o = new OptionParser(); 4858 | $o->get_specs(); 4859 | $o->get_opts(); 4860 | 4861 | $dp = $o->DSNParser(); 4862 | $dp->prop('set-vars', $o->set_vars()); 4863 | 4864 | $o->set('verbose', 0) if $o->get('quiet'); 4865 | 4866 | if ( !$o->get('help') ) { 4867 | if ( $o->get('until-master') ) { 4868 | if ( $o->get('until-master') !~ m/^[.\w-]+,\d+$/ ) { 4869 | $o->save_error("Invalid --until-master argument, must be file,pos"); 4870 | } 4871 | } 4872 | if ( $o->get('until-relay') ) { 4873 | if ( $o->get('until-relay') !~ m/^[.\w-]+,\d+$/ ) { 4874 | $o->save_error("Invalid --until-relay argument, must be file,pos"); 4875 | } 4876 | } 4877 | } 4878 | 4879 | eval { 4880 | MasterSlave::check_recursion_method($o->get('recursion-method')); 4881 | }; 4882 | if ( $EVAL_ERROR ) { 4883 | $o->save_error("Invalid --recursion-method: $EVAL_ERROR") 4884 | } 4885 | 4886 | $o->usage_or_errors(); 4887 | 4888 | # ######################################################################## 4889 | # First things first: if --stop was given, create the sentinel file. 4890 | # ######################################################################## 4891 | my $sentinel = $o->get('sentinel'); 4892 | if ( $o->get('stop') ) { 4893 | PTDEBUG && _d('Creating sentinel file', $sentinel); 4894 | my $file = IO::File->new($sentinel, ">>") 4895 | or die "Cannot open $sentinel: $OS_ERROR\n"; 4896 | print $file "Remove this file to permit pt-slave-restart to run\n" 4897 | or die "Cannot write to $sentinel: $OS_ERROR\n"; 4898 | close $file 4899 | or die "Cannot close $sentinel: $OS_ERROR\n"; 4900 | print STDOUT "Successfully created file $sentinel\n" 4901 | unless $o->get('quiet'); 4902 | # Exit unlesss --monitor is given. 4903 | if ( !$o->got('monitor') ) { 4904 | PTDEBUG && _d('Nothing more to do, quitting'); 4905 | return 0; 4906 | } 4907 | else { 4908 | # Wait for all other running instances to quit, assuming they have the 4909 | # same --interval as this invocation. Then remove the file and 4910 | # continue. 4911 | PTDEBUG && _d('Waiting for other instances to quit'); 4912 | sleep $o->get('max-sleep'); 4913 | PTDEBUG && _d('Unlinking', $sentinel); 4914 | unlink $sentinel 4915 | or die "Cannot unlink $sentinel: $OS_ERROR"; 4916 | } 4917 | } 4918 | 4919 | # ######################################################################## 4920 | # Connect to MySQL. 4921 | # ######################################################################## 4922 | if ( $o->get('ask-pass') ) { 4923 | $o->set('password', OptionParser::prompt_noecho("Enter password: ")); 4924 | } 4925 | my $dsn_defaults = $dp->parse_options($o); 4926 | my $dsn = @ARGV ? $dp->parse(shift @ARGV, $dsn_defaults) 4927 | : $dsn_defaults; 4928 | my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn), 4929 | { AutoCommit => 1, }); 4930 | 4931 | $dbh->{InactiveDestroy} = 1; # Don't disconnect on fork/daemonize 4932 | 4933 | # Daemonize only after connecting and doing --ask-pass. 4934 | my $daemon; 4935 | if ( $o->get('daemonize') ) { 4936 | $daemon = new Daemon(o=>$o); 4937 | $daemon->daemonize(); 4938 | PTDEBUG && _d('I am a daemon now'); 4939 | } 4940 | elsif ( $o->get('pid') ) { 4941 | # We're not daemoninzing, it just handles PID stuff. 4942 | $daemon = new Daemon(o=>$o); 4943 | $daemon->make_PID_file(); 4944 | } 4945 | 4946 | # ######################################################################## 4947 | # Start monitoring the slave. 4948 | # ######################################################################## 4949 | my $exit_status = 0; 4950 | my @servers_to_watch; 4951 | 4952 | # Despite the name, recursing to slaves actually begins at the specified 4953 | # server, so the named server may also be watched, if it's a slave. 4954 | my $ms = new MasterSlave( 4955 | OptionParser => $o, 4956 | DSNParser => $dp, 4957 | Quoter => $q, 4958 | ); 4959 | $ms->recurse_to_slaves( 4960 | { dbh => $dbh, 4961 | dsn => $dsn, 4962 | callback => sub { 4963 | my ( $dsn, $dbh, $level ) = @_; 4964 | # Test whether we want to watch this server. 4965 | eval { 4966 | my $stat = $ms->get_slave_status($dbh); 4967 | if ( $stat ) { 4968 | push @servers_to_watch, { dsn => $dsn, dbh => $dbh }; 4969 | } 4970 | else { 4971 | die "could not find slave status on this server\n"; 4972 | } 4973 | }; 4974 | if ( $EVAL_ERROR ) { 4975 | chomp $EVAL_ERROR; 4976 | PTDEBUG && _d('Not watching', $dp->as_string($dsn), 4977 | 'because', $EVAL_ERROR); 4978 | } 4979 | }, 4980 | skip_callback => sub { 4981 | my ( $dsn, $dbh, $level ) = @_; 4982 | print STDERR "Skipping ", $dp->as_string($dsn), "\n"; 4983 | }, 4984 | } 4985 | ); 4986 | 4987 | # ######################################################################## 4988 | # Do the version-check 4989 | # ######################################################################## 4990 | if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) { 4991 | VersionCheck::version_check( 4992 | force => $o->got('version-check'), 4993 | instances => [ { dbh => $dbh, dsn => $dsn }, @servers_to_watch ], 4994 | ); 4995 | } 4996 | 4997 | # ######################################################################## 4998 | # Watch each server found. 4999 | # ######################################################################## 5000 | my $must_fork = @servers_to_watch > 1; 5001 | foreach my $host ( @servers_to_watch ) { 5002 | 5003 | $host->{dbh}->{InactiveDestroy} = 1; # Don't disconnect on fork 5004 | 5005 | # Fork, but only if there might be more than one host to watch. 5006 | my $pid = $must_fork ? fork() : undef; 5007 | if ( !$must_fork || (defined($pid) && $pid == 0) ) { 5008 | # I either forked and I'm a child, or I didn't fork... confusing, eh? 5009 | watch_server($host->{dsn}, $host->{dbh}, $must_fork, $ms); 5010 | } 5011 | elsif ( $must_fork && !defined($pid) ) { 5012 | die("Unable to fork!"); 5013 | } 5014 | # I already exited if I'm a child, so I'm the parent. (Or maybe I never 5015 | # forked). 5016 | $children{$dp->as_string($host->{dsn})} = $pid if $must_fork; 5017 | } 5018 | 5019 | PTDEBUG && _d('Child PIDs:', values %children); 5020 | # Wait for the children to exit. 5021 | foreach my $host ( keys %children ) { 5022 | PTDEBUG && _d('Waiting to reap', $host); 5023 | my $pid = waitpid($children{$host}, 0); 5024 | $exit_status ||= $CHILD_ERROR >> 8; 5025 | } 5026 | 5027 | $dp->disconnect($dbh); 5028 | return $exit_status; 5029 | } 5030 | 5031 | # ############################################################################ 5032 | # Subroutines. 5033 | # ############################################################################ 5034 | 5035 | # Actually watch a server. If many instances are being watched, this is 5036 | # fork()ed. 5037 | sub watch_server { 5038 | my ( $dsn, $dbh, $was_forked, $ms ) = @_; 5039 | 5040 | PTDEBUG && _d('Watching server', $dp->as_string($dsn), 5041 | 'forked:', $was_forked); 5042 | 5043 | my $start_sql = VersionParser->new($dbh) >= '4.0.5' 5044 | ? 'START SLAVE' : 'SLAVE START'; 5045 | if ( $o->get('until-master') ) { 5046 | my ( $file, $pos ) = split(',', $o->get('until-master')); 5047 | $start_sql .= " UNTIL MASTER_LOG_FILE = '$file', MASTER_LOG_POS = $pos"; 5048 | } 5049 | elsif ( $o->get('until-relay') ) { 5050 | my ( $file, $pos ) = split(',', $o->get('until-relay')); 5051 | $start_sql .= " UNTIL RELAY_LOG_FILE = '$file', RELAY_LOG_POS = $pos"; 5052 | } 5053 | 5054 | my $start = $dbh->prepare($start_sql); 5055 | my $stop = $dbh->prepare('STOP SLAVE'); 5056 | 5057 | # ######################################################################## 5058 | # Detect if GTID is enabled. Skipping an event is done differently. 5059 | # ######################################################################## 5060 | # When MySQL 5.6.5 or higher is used and gtid is enabled, skipping a 5061 | # transaction is not possible with SQL_SLAVE_SKIP_COUNTER 5062 | my $skip_event; 5063 | my $have_gtid = 0; 5064 | if ( VersionParser->new($dbh) >= '5.6.5' ) { 5065 | my $row = $dbh->selectrow_arrayref('SELECT @@GLOBAL.gtid_mode'); 5066 | PTDEBUG && _d('@@GLOBAL.gtid_mode:', $row->[0]); 5067 | if ( $row && $row->[0] eq 'ON' ) { 5068 | $have_gtid = 1; 5069 | } 5070 | } 5071 | PTDEBUG && _d('Have GTID:', $have_gtid); 5072 | 5073 | # If GTID is enabled, slave_parallel_workers should be == 0. 5074 | # It's currently not possible to know what GTID event the failed trx is. 5075 | if ( $have_gtid ) { 5076 | my $threads = $dbh->selectrow_hashref( 5077 | 'SELECT @@GLOBAL.slave_parallel_workers AS threads'); 5078 | if ( $threads->{threads} > 0 ) { 5079 | die "Cannot skip transactions properly because GTID is enabled " 5080 | . "and slave_parallel_workers > 0. See 'GLOBAL TRANSACTION IDS' " 5081 | . "in the tool's documentation.\n"; 5082 | } 5083 | } 5084 | 5085 | 5086 | # ######################################################################## 5087 | # Lookup tables of things to do when a problem is detected. 5088 | # ######################################################################## 5089 | my @error_patterns = ( 5090 | [ qr/You have an error in your SQL/ => 'refetch_relay_log' ], 5091 | [ qr/Could not parse relay log event entry/ => 'refetch_relay_log' ], 5092 | [ qr/Incorrect key file for table/ => 'repair_table' ], 5093 | [ qr/Delete_rows event on table/ => 'skip' ], 5094 | [ qr/Unknown table/ => 'skip' ], 5095 | [ qr/Duplicate entry/ => 'skip' ], 5096 | ); 5097 | 5098 | # ######################################################################## 5099 | # These are actions to take when an error is found. 5100 | # ######################################################################## 5101 | my %actions = ( 5102 | refetch_relay_log => sub { 5103 | my ( $stat, $dbh ) = @_; 5104 | PTDEBUG && _d('Found relay log corruption'); 5105 | # Can't do CHANGE MASTER TO with a running slave. 5106 | $stop->execute(); 5107 | 5108 | # Cannot use ? placeholders for CHANGE MASTER values: 5109 | # https://bugs.launchpad.net/percona-toolkit/+bug/932614 5110 | my $sql = "CHANGE MASTER TO " 5111 | . "MASTER_LOG_FILE='$stat->{relay_master_log_file}', " 5112 | . "MASTER_LOG_POS=$stat->{exec_master_log_pos}"; 5113 | PTDEBUG && _d($sql); 5114 | $dbh->do($sql); 5115 | }, 5116 | skip => sub { 5117 | my ( $stat, $dbh ) = @_; 5118 | PTDEBUG && _d("when RBR OR MBR dealing with HA_ERR_KEY_NOT_FOUND, 5119 | set global slave_exec_mode= IDEMPOTENT would be better, 5120 | more detail info please refer the blog: 5121 | http://blog.csdn.net/dba_waterbin/article/details/41369819 5122 | "); 5123 | 5124 | my $master_dbh ; 5125 | my $master_host = $stat->{master_host}; 5126 | my $master_port = $stat->{master_port}; 5127 | my $master_user = "repl"; 5128 | my $master_pass = "repl"; 5129 | 5130 | PTDEBUG && _d("waterbin $master_host $master_port"); 5131 | eval{ 5132 | $master_dbh = DBI->connect("dbi:mysql:test:$master_host:$master_port",$master_user,$master_pass); 5133 | }; 5134 | if($@) 5135 | { 5136 | PTDEBUG && _d("Fail to connect to Master"); 5137 | exit; 5138 | } 5139 | 5140 | my $v_sql = 'SELECT @@BINLOG_FORMAT'; 5141 | my $binlog_format = $master_dbh->selectrow_array($v_sql); 5142 | PTDEBUG && _d("waterbinlin $binlog_format"); 5143 | my $set_skip_common = $dbh->prepare("SET GLOBAL SQL_SLAVE_SKIP_COUNTER = " 5144 | . $o->get('skip-count')); 5145 | my $set_skip_idempotent = $dbh->prepare("SET GLOBAL SLAVE_EXEC_MODE = IDEMPOTENT"); 5146 | $binlog_format eq 'STATEMENT' 5147 | ? $set_skip_common->execute() 5148 | : $set_skip_idempotent->execute(); 5149 | PTDEBUG && _d("waterbin $binlog_format"); 5150 | }, 5151 | skip_gtid => sub { 5152 | my ( $stat, $dbh ) = @_; 5153 | 5154 | # Get master_uuid from SHOW SLAVE STATUS if a UUID is not specified 5155 | # with --master-uuid. 5156 | my $gtid_uuid = $o->get('master-uuid'); 5157 | if ( !$gtid_uuid ) { 5158 | $gtid_uuid = $stat->{master_uuid}; 5159 | die "No master_uuid" unless $gtid_uuid; # shouldn't happen 5160 | } 5161 | 5162 | # We need the highest transaction in the executed_gtid_set. 5163 | # and then we need to increase it by 1 (the one we want to skip) 5164 | # Notes: 5165 | # - does not work with parallel replication 5166 | # - it skips the next transaction from the master_uuid 5167 | # (when a slaveB is replicating from slaveA, 5168 | # the master_uuid is it's own master, slaveA) 5169 | my ($gtid_exec_ids) = ($stat->{executed_gtid_set} || '') =~ m/$gtid_uuid([0-9-:]*)/; 5170 | $gtid_exec_ids =~ s/:[0-9]-/:/g; 5171 | die "No executed GTIDs" unless $gtid_exec_ids; 5172 | 5173 | my @gtid_exec_ranges = split(/:/, $gtid_exec_ids); 5174 | delete $gtid_exec_ranges[0]; # undef the first value, it's always empty 5175 | 5176 | # Get the highest id by sorting the array, removing the undef value. 5177 | my @gtid_exec_sorted = sort { $a <=> $b } 5178 | grep { defined($_) } @gtid_exec_ranges; 5179 | my $gtid_exec_last = $gtid_exec_sorted[-1]; 5180 | 5181 | PTDEBUG && _d("\n", 5182 | "GTID: master_uuid:", $gtid_uuid, "\n", 5183 | "GTID: executed_gtid_set:", $gtid_exec_ids, "\n", 5184 | "GTID: max for master_uuid:", $gtid_exec_sorted[-1], "\n", 5185 | "GTID: last executed gtid:", $gtid_uuid, ":", $gtid_exec_last); 5186 | 5187 | # Set the sessions next gtid, write an empty transaction 5188 | my $skipped = 0; 5189 | while ( $skipped++ < $o->get('skip-count') ) { 5190 | my $gtid_next = $gtid_exec_last + $skipped; 5191 | my $sql = "SET GTID_NEXT='$gtid_uuid:$gtid_next'"; 5192 | PTDEBUG && _d($sql); 5193 | my $sth = $dbh->prepare($sql); 5194 | $sth->execute(); 5195 | $dbh->begin_work(); 5196 | $dbh->commit(); 5197 | } 5198 | 5199 | # Set the session back to the automatically generated GTID_NEXT. 5200 | $dbh->do("SET GTID_NEXT='AUTOMATIC'"); 5201 | }, 5202 | repair_table => sub { 5203 | my ( $stat, $dbh ) = @_; 5204 | PTDEBUG && _d('Found corrupt table'); 5205 | # [ qr/Incorrect key file for table './foo/bar.MYI' 5206 | my ( $db, $tbl ) = $stat->{last_error} =~ m!([^/]+)/(.*?)\.MYI!; 5207 | if ( $db && $tbl ) { 5208 | my $sql = "REPAIR TABLE " . $q->quote($db, $tbl); 5209 | PTDEBUG && _d($sql); 5210 | $dbh->do($sql); 5211 | } 5212 | }, 5213 | ); 5214 | 5215 | my $err_text = $o->get('error-text'); 5216 | my $exit_time = time() + ($o->get('run-time') || 0); 5217 | my $sleep = $o->get('sleep'); 5218 | my ($last_log, $last_pos); 5219 | 5220 | my $stat = {}; # Will hold SHOW SLAVE STATUS 5221 | STAT: 5222 | while ( $stat 5223 | && (!$o->get('run-time') || time() < $exit_time) 5224 | && !-f $o->get('sentinel') ) { 5225 | my $increase_sleep = 1; 5226 | $stat = $ms->get_slave_status($dbh); 5227 | if ( !$stat ) { 5228 | print STDERR "No SLAVE STATUS output found on ", 5229 | $dp->as_string($dsn), "\n"; 5230 | next STAT; 5231 | } 5232 | 5233 | PTDEBUG && _d('Last/current relay log file:', 5234 | $last_log, $stat->{relay_log_file}); 5235 | PTDEBUG && _d('Last/current relay log pos:', 5236 | $last_pos, $stat->{relay_log_pos}); 5237 | if ( !$last_log 5238 | || $last_log ne $stat->{relay_log_file} # Avoid infinite loops 5239 | || $last_pos != $stat->{relay_log_pos} 5240 | ) { 5241 | $stat->{slave_sql_running} ||= 'No'; 5242 | $stat->{last_error} ||= ''; 5243 | $stat->{last_errno} ||= 0; 5244 | 5245 | if ( $o->get('until-master') && pos_ge($stat, 'master') ) { 5246 | die "Slave has advanced past " . $o->get('until-master') 5247 | . " on master.\n"; 5248 | } 5249 | elsif ( $o->get('until-relay') && pos_ge($stat, 'relay') ) { 5250 | die "Slave has advanced past " . $o->get('until-relay') 5251 | . " in relay logs.\n"; 5252 | } 5253 | 5254 | if ( $stat->{slave_sql_running} eq 'No' ) { 5255 | # Print the time, error, etc 5256 | if ( $o->get('verbose') ) { 5257 | my $err = ''; 5258 | if ( $o->get('verbose') > 1 ) { 5259 | ($err = $stat->{last_error} || '' ) =~ s/\s+/ /g; 5260 | if ( $o->get('error-length') ) { 5261 | $err = substr($err, 0, $o->get('error-length')); 5262 | } 5263 | } 5264 | printf("%s %s %s %11d %d %s %s\n", 5265 | ts(time), 5266 | $dp->as_string($dsn), 5267 | $stat->{relay_log_file}, 5268 | $stat->{relay_log_pos}, 5269 | $stat->{last_errno} || 0, 5270 | $err, 5271 | "Start self-healing" 5272 | ); 5273 | } 5274 | 5275 | if ( $o->got('error-numbers') 5276 | && !exists($o->get('error-numbers')->{$stat->{last_errno}}) ) { 5277 | die "Error $stat->{last_errno} is not in --error-numbers.\n"; 5278 | } 5279 | elsif ( $err_text 5280 | && $stat->{last_error} 5281 | && $stat->{last_error} !~ m/$err_text/ ) { 5282 | die "Error does not match --error-text.\n"; 5283 | } 5284 | elsif ( $stat->{last_error} || $o->get('always') ) { 5285 | 5286 | # What kind of error is it? 5287 | foreach my $pat ( @error_patterns ) { 5288 | if ( $stat->{last_error} =~ m/$pat->[0]/ ) { 5289 | $actions{$pat->[1]}->($stat, $dbh); 5290 | last; 5291 | } 5292 | } 5293 | 5294 | $start->execute(); 5295 | $increase_sleep = 0; 5296 | 5297 | # Only set this on events I tried to restart. Otherwise there 5298 | # could be a race condition: I see it, I record it, but it hasn't 5299 | # caused an error yet; so I won't try to restart it when it does. 5300 | # (The point of this is to avoid trying to restart the same event 5301 | # twice in case another race condition happens -- I restart it, 5302 | # then check the server and it hasn't yet cleared the error 5303 | # message and restarted the SQL thread). 5304 | if ( $o->get('check-relay-log') ) { 5305 | $last_log = $stat->{relay_log_file}; 5306 | $last_pos = $stat->{relay_log_pos}; 5307 | } 5308 | } 5309 | else { 5310 | PTDEBUG && _d('The slave is stopped, but without error'); 5311 | $increase_sleep = 1; 5312 | } 5313 | } 5314 | elsif ( $o->get('verbose') > 2 ) { 5315 | printf("%s delayed %s sec\n", $dp->as_string($dsn), 5316 | (defined $stat->{seconds_behind_master} ? 5317 | $stat->{seconds_behind_master} : 'NULL')); 5318 | } 5319 | } 5320 | else { 5321 | if ( $o->get('verbose') ) { 5322 | print "Not checking slave because relay log file or position has " 5323 | . "not changed " 5324 | . "(file " . ($last_log || '') 5325 | . " pos " . ($last_pos || '') . ")\n"; 5326 | } 5327 | } 5328 | 5329 | # Adjust sleep time. 5330 | if ( $increase_sleep ) { 5331 | $sleep = min($o->get('max-sleep'), $sleep * 2); 5332 | } 5333 | else { 5334 | $sleep = max($o->get('min-sleep'), $sleep / 2); 5335 | } 5336 | 5337 | # Errors are very likely to follow each other in quick succession. NOTE: 5338 | # this policy has a side effect with respect to $sleep. Suppose $sleep is 5339 | # 512 and pt-slave-restart finds an error; now $sleep is 256, but 5340 | # pt-slave-restart sleeps only 1 (the initial value of --sleep). Suppose 5341 | # there is no error when it wakes up after 1 second, because 1 was too 5342 | # short. Now it doubles $sleep, back to 512. $sleep has the same value 5343 | # it did before the error was ever found. 5344 | my $sleep_time = $increase_sleep ? $sleep : min($sleep, $o->get('sleep')); 5345 | if ( $o->get('verbose') > 2 ) { 5346 | printf("%s sleeping %f\n", $dp->as_string($dsn), $sleep_time); 5347 | } 5348 | sleep $sleep_time; 5349 | } 5350 | 5351 | PTDEBUG && _d('All done with server', $dp->as_string($dsn)); 5352 | if ( $was_forked ) { 5353 | $dp->disconnect($dbh); 5354 | exit(0); 5355 | } 5356 | } 5357 | 5358 | # Determines if the $stat's log coordinates are greater than or equal to the 5359 | # desired coordinates. $which is 'master' or 'relay' 5360 | sub pos_ge { 5361 | my ( $stat, $which ) = @_; 5362 | my $fmt = '%s/%020d'; 5363 | my $curr = $which eq 'master' 5364 | ? sprintf($fmt, @{$stat}{qw(relay_master_log_file exec_master_log_pos)}) 5365 | : sprintf($fmt, @{$stat}{qw(relay_log_file relay_log_pos)}); 5366 | my $stop = sprintf($fmt, split(',', $o->get("until-$which"))); 5367 | return $curr ge $stop; 5368 | } 5369 | 5370 | sub ts { 5371 | my ( $time ) = @_; 5372 | my ( $sec, $min, $hour, $mday, $mon, $year ) 5373 | = localtime($time); 5374 | $mon += 1; 5375 | $year += 1900; 5376 | return sprintf("%d-%02d-%02dT%02d:%02d:%02d", 5377 | $year, $mon, $mday, $hour, $min, $sec); 5378 | } 5379 | 5380 | # Catches signals for exiting gracefully. 5381 | sub finish { 5382 | my ($signal) = @_; 5383 | print STDERR "Exiting on SIG$signal.\n"; 5384 | if ( %children ) { 5385 | kill 9, values %children; 5386 | print STDERR "Signaled ", join(', ', values %children), "\n"; 5387 | } 5388 | exit(1); 5389 | } 5390 | 5391 | sub _d { 5392 | my ($package, undef, $line) = caller 0; 5393 | @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 5394 | map { defined $_ ? $_ : 'undef' } 5395 | @_; 5396 | print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 5397 | } 5398 | 5399 | # ############################################################################ 5400 | # Run the program. 5401 | # ############################################################################ 5402 | if ( !caller ) { exit main(@ARGV); } 5403 | 5404 | 1; # Because this is a module as well as a script. 5405 | 5406 | # ############################################################################ 5407 | # Documentation. 5408 | # ############################################################################ 5409 | 5410 | =pod 5411 | 5412 | =head1 NAME 5413 | 5414 | pt-slave-restart - Watch and restart MySQL replication after errors. 5415 | 5416 | =head1 SYNOPSIS 5417 | 5418 | Usage: pt-slave-restart [OPTIONS] [DSN] 5419 | 5420 | pt-slave-restart watches one or more MySQL replication slaves for 5421 | errors, and tries to restart replication if it stops. 5422 | 5423 | =head1 RISKS 5424 | 5425 | Percona Toolkit is mature, proven in the real world, and well tested, 5426 | but all database tools can pose a risk to the system and the database 5427 | server. Before using this tool, please: 5428 | 5429 | =over 5430 | 5431 | =item * Read the tool's documentation 5432 | 5433 | =item * Review the tool's known L<"BUGS"> 5434 | 5435 | =item * Test the tool on a non-production server 5436 | 5437 | =item * Backup your production server and verify the backups 5438 | 5439 | =back 5440 | 5441 | =head1 DESCRIPTION 5442 | 5443 | pt-slave-restart watches one or more MySQL replication slaves and tries to skip 5444 | statements that cause errors. It polls slaves intelligently with an 5445 | exponentially varying sleep time. You can specify errors to skip and run the 5446 | slaves until a certain binlog position. 5447 | 5448 | Although this tool can help a slave advance past errors, you should not 5449 | rely on it to "fix" replication. If slave errors occur frequently or 5450 | unexpectedly, you should identify and fix the root cause. 5451 | 5452 | =head1 OUTPUT 5453 | 5454 | If you specify L<"--verbose">, pt-slave-restart prints a line every time it sees 5455 | the slave has an error. See L<"--verbose"> for details. 5456 | 5457 | =head1 SLEEP 5458 | 5459 | pt-slave-restart sleeps intelligently between polling the slave. The current 5460 | sleep time varies. 5461 | 5462 | =over 5463 | 5464 | =item * 5465 | 5466 | The initial sleep time is given by L<"--sleep">. 5467 | 5468 | =item * 5469 | 5470 | If it checks and finds an error, it halves the previous sleep time. 5471 | 5472 | =item * 5473 | 5474 | If it finds no error, it doubles the previous sleep time. 5475 | 5476 | =item * 5477 | 5478 | The sleep time is bounded below by L<"--min-sleep"> and above by 5479 | L<"--max-sleep">. 5480 | 5481 | =item * 5482 | 5483 | Immediately after finding an error, pt-slave-restart assumes another error is 5484 | very likely to happen next, so it sleeps the current sleep time or the initial 5485 | sleep time, whichever is less. 5486 | 5487 | =back 5488 | 5489 | =head1 GLOBAL TRANSACTION IDS 5490 | 5491 | As of Percona Toolkit 2.2.8, pt-slave-restart supports Global Transaction IDs 5492 | introduced in MySQL 5.6.5. It's important to keep in mind that: 5493 | 5494 | =over 5495 | 5496 | =item * 5497 | 5498 | pt-slave-restart will not skip transactions when multiple replication threads 5499 | are being used (slave_parallel_workers > 0). pt-slave-restart does not know 5500 | what the GTID event is of the failed transaction of a specific slave thread. 5501 | 5502 | =item * 5503 | 5504 | The default behavior is to skip the next transaction from the slave's master. 5505 | Writes can originate on different servers, each with their own UUID. 5506 | 5507 | See L<"--master-uuid">. 5508 | 5509 | =back 5510 | 5511 | =head1 EXIT STATUS 5512 | 5513 | An exit status of 0 (sometimes also called a return value or return code) 5514 | indicates success. Any other value represents the exit status of the Perl 5515 | process itself, or of the last forked process that exited if there were multiple 5516 | servers to monitor. 5517 | 5518 | =head1 COMPATIBILITY 5519 | 5520 | pt-slave-restart should work on many versions of MySQL. Lettercase of many 5521 | output columns from SHOW SLAVE STATUS has changed over time, so it treats them 5522 | all as lowercase. 5523 | 5524 | =head1 OPTIONS 5525 | 5526 | This tool accepts additional command-line arguments. Refer to the 5527 | L<"SYNOPSIS"> and usage information for details. 5528 | 5529 | =over 5530 | 5531 | =item --always 5532 | 5533 | Start slaves even when there is no error. With this option enabled, 5534 | pt-slave-restart will not let you stop the slave manually if you want to! 5535 | 5536 | =item --ask-pass 5537 | 5538 | Prompt for a password when connecting to MySQL. 5539 | 5540 | =item --charset 5541 | 5542 | short form: -A; type: string 5543 | 5544 | Default character set. If the value is utf8, sets Perl's binmode on 5545 | STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and 5546 | runs SET NAMES UTF8 after connecting to MySQL. Any other value sets 5547 | binmode on STDOUT without the utf8 layer, and runs SET NAMES after 5548 | connecting to MySQL. 5549 | 5550 | =item --[no]check-relay-log 5551 | 5552 | default: yes 5553 | 5554 | Check the last relay log file and position before checking for slave errors. 5555 | 5556 | By default pt-slave-restart will not doing anything (it will just sleep) 5557 | if neither the relay log file nor the relay log position have changed since 5558 | the last check. This prevents infinite loops (i.e. restarting the same 5559 | error in the same relay log file at the same relay log position). 5560 | 5561 | For certain slave errors, however, this check needs to be disabled by 5562 | specifying C<--no-check-relay-log>. Do not do this unless you know what 5563 | you are doing! 5564 | 5565 | =item --config 5566 | 5567 | type: Array 5568 | 5569 | Read this comma-separated list of config files; if specified, this must be the 5570 | first option on the command line. 5571 | 5572 | =item --daemonize 5573 | 5574 | Fork to the background and detach from the shell. POSIX 5575 | operating systems only. 5576 | 5577 | =item --database 5578 | 5579 | short form: -D; type: string 5580 | 5581 | Database to use. 5582 | 5583 | =item --defaults-file 5584 | 5585 | short form: -F; type: string 5586 | 5587 | Only read mysql options from the given file. You must give an absolute 5588 | pathname. 5589 | 5590 | =item --error-length 5591 | 5592 | type: int 5593 | 5594 | Max length of error message to print. When L<"--verbose"> is set high enough to 5595 | print the error, this option will truncate the error text to the specified 5596 | length. This can be useful to prevent wrapping on the terminal. 5597 | 5598 | =item --error-numbers 5599 | 5600 | type: hash 5601 | 5602 | Only restart this comma-separated list of errors. Makes pt-slave-restart only 5603 | try to restart if the error number is in this comma-separated list of errors. 5604 | If it sees an error not in the list, it will exit. 5605 | 5606 | The error number is in the C column of C. 5607 | 5608 | =item --error-text 5609 | 5610 | type: string 5611 | 5612 | Only restart errors that match this pattern. A Perl regular expression against 5613 | which the error text, if any, is matched. If the error text exists and matches, 5614 | pt-slave-restart will try to restart the slave. If it exists but doesn't match, 5615 | pt-slave-restart will exit. 5616 | 5617 | The error text is in the C column of C. 5618 | 5619 | =item --help 5620 | 5621 | Show help and exit. 5622 | 5623 | =item --host 5624 | 5625 | short form: -h; type: string 5626 | 5627 | Connect to host. 5628 | 5629 | =item --log 5630 | 5631 | type: string 5632 | 5633 | Print all output to this file when daemonized. 5634 | 5635 | =item --max-sleep 5636 | 5637 | type: float; default: 64 5638 | 5639 | Maximum sleep seconds. 5640 | 5641 | The maximum time pt-slave-restart will sleep before polling the slave again. 5642 | This is also the time that pt-slave-restart will wait for all other running 5643 | instances to quit if both L<"--stop"> and L<"--monitor"> are specified. 5644 | 5645 | See L<"SLEEP">. 5646 | 5647 | =item --min-sleep 5648 | 5649 | type: float; default: 0.015625 5650 | 5651 | The minimum time pt-slave-restart will sleep before polling the slave again. 5652 | See L<"SLEEP">. 5653 | 5654 | =item --monitor 5655 | 5656 | Whether to monitor the slave (default). Unless you specify --monitor 5657 | explicitly, L<"--stop"> will disable it. 5658 | 5659 | =item --password 5660 | 5661 | short form: -p; type: string 5662 | 5663 | Password to use when connecting. 5664 | If password contains commas they must be escaped with a backslash: "exam\,ple" 5665 | 5666 | =item --pid 5667 | 5668 | type: string 5669 | 5670 | Create the given PID file. The tool won't start if the PID file already 5671 | exists and the PID it contains is different than the current PID. However, 5672 | if the PID file exists and the PID it contains is no longer running, the 5673 | tool will overwrite the PID file with the current PID. The PID file is 5674 | removed automatically when the tool exits. 5675 | 5676 | =item --port 5677 | 5678 | short form: -P; type: int 5679 | 5680 | Port number to use for connection. 5681 | 5682 | =item --quiet 5683 | 5684 | short form: -q 5685 | 5686 | Suppresses normal output (disables L<"--verbose">). 5687 | 5688 | =item --recurse 5689 | 5690 | type: int; default: 0 5691 | 5692 | Watch slaves of the specified server, up to the specified number of servers deep 5693 | in the hierarchy. The default depth of 0 means "just watch the slave 5694 | specified." 5695 | 5696 | pt-slave-restart examines C and tries to determine which 5697 | connections are from slaves, then connect to them. See L<"--recursion-method">. 5698 | 5699 | Recursion works by finding all slaves when the program starts, then watching 5700 | them. If there is more than one slave, C uses C to 5701 | monitor them. 5702 | 5703 | This also works if you have configured your slaves to show up in C. The minimal configuration for this is the C parameter, but 5705 | there are other "report" parameters as well for the port, username, and 5706 | password. 5707 | 5708 | =item --recursion-method 5709 | 5710 | type: array; default: processlist,hosts 5711 | 5712 | Preferred recursion method used to find slaves. 5713 | 5714 | Possible methods are: 5715 | 5716 | METHOD USES 5717 | =========== ================== 5718 | processlist SHOW PROCESSLIST 5719 | hosts SHOW SLAVE HOSTS 5720 | none Do not find slaves 5721 | 5722 | The processlist method is preferred because SHOW SLAVE HOSTS is not reliable. 5723 | However, the hosts method is required if the server uses a non-standard 5724 | port (not 3306). Usually pt-slave-restart does the right thing and finds 5725 | the slaves, but you may give a preferred method and it will be used first. 5726 | If it doesn't find any slaves, the other methods will be tried. 5727 | 5728 | =item --run-time 5729 | 5730 | type: time 5731 | 5732 | Time to run before exiting. Causes pt-slave-restart to stop after the specified 5733 | time has elapsed. Optional suffix: s=seconds, m=minutes, h=hours, d=days; if no 5734 | suffix, s is used. 5735 | 5736 | =item --sentinel 5737 | 5738 | type: string; default: /tmp/pt-slave-restart-sentinel 5739 | 5740 | Exit if this file exists. 5741 | 5742 | =item --set-vars 5743 | 5744 | type: Array 5745 | 5746 | Set the MySQL variables in this comma-separated list of C pairs. 5747 | 5748 | By default, the tool sets: 5749 | 5750 | =for comment ignore-pt-internal-value 5751 | MAGIC_set_vars 5752 | 5753 | wait_timeout=10000 5754 | 5755 | Variables specified on the command line override these defaults. For 5756 | example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>. 5757 | 5758 | The tool prints a warning and continues if a variable cannot be set. 5759 | 5760 | =item --skip-count 5761 | 5762 | type: int; default: 1 5763 | 5764 | Number of statements to skip when restarting the slave. 5765 | 5766 | =item --master-uuid 5767 | 5768 | type: string 5769 | 5770 | When using GTID, an empty transaction should be created in order to skip it. 5771 | If writes are coming from different nodes in the replication tree above, it is 5772 | not possible to know which event from which UUID to skip. 5773 | 5774 | By default, transactions from the slave's master (C<'Master_UUID'> from 5775 | C) are skipped. 5776 | 5777 | For example, with 5778 | 5779 | master1 -> slave1 -> slave2 5780 | 5781 | When skipping events on slave2 that were written to master1, you must specify 5782 | the UUID of master1, else the tool will use the UUID of slave1 by default. 5783 | 5784 | See L<"GLOBAL TRANSACTION IDS">. 5785 | 5786 | =item --sleep 5787 | 5788 | type: int; default: 1 5789 | 5790 | Initial sleep seconds between checking the slave. 5791 | 5792 | See L<"SLEEP">. 5793 | 5794 | =item --socket 5795 | 5796 | short form: -S; type: string 5797 | 5798 | Socket file to use for connection. 5799 | 5800 | =item --stop 5801 | 5802 | Stop running instances by creating the sentinel file. 5803 | 5804 | Causes C to create the sentinel file specified by 5805 | L<"--sentinel">. This should have the effect of stopping all running 5806 | instances which are watching the same sentinel file. If L<"--monitor"> isn't 5807 | specified, C will exit after creating the file. If it is 5808 | specified, C will wait the interval given by 5809 | L<"--max-sleep">, then remove the file and continue working. 5810 | 5811 | You might find this handy to stop cron jobs gracefully if necessary, or to 5812 | replace one running instance with another. For example, if you want to stop 5813 | and restart C every hour (just to make sure that it is 5814 | restarted every hour, in case of a server crash or some other problem), you 5815 | could use a C line like this: 5816 | 5817 | 0 * * * * pt-slave-restart --monitor --stop --sentinel /tmp/pt-slave-restartup 5818 | 5819 | The non-default L<"--sentinel"> will make sure the hourly C job stops 5820 | only instances previously started with the same options (that is, from the 5821 | same C job). 5822 | 5823 | See also L<"--sentinel">. 5824 | 5825 | =item --until-master 5826 | 5827 | type: string 5828 | 5829 | Run until this master log file and position. Start the slave, and retry if it 5830 | fails, until it reaches the given replication coordinates. The coordinates are 5831 | the logfile and position on the master, given by relay_master_log_file, 5832 | exec_master_log_pos. The argument must be in the format "file,pos". Separate 5833 | the filename and position with a single comma and no space. 5834 | 5835 | This will also cause an UNTIL clause to be given to START SLAVE. 5836 | 5837 | After reaching this point, the slave should be stopped and pt-slave-restart 5838 | will exit. 5839 | 5840 | =item --until-relay 5841 | 5842 | type: string 5843 | 5844 | Run until this relay log file and position. Like L<"--until-master">, but in 5845 | the slave's relay logs instead. The coordinates are given by relay_log_file, 5846 | relay_log_pos. 5847 | 5848 | =item --user 5849 | 5850 | short form: -u; type: string 5851 | 5852 | User for login if not current user. 5853 | 5854 | =item --verbose 5855 | 5856 | short form: -v; cumulative: yes; default: 1 5857 | 5858 | Be verbose; can specify multiple times. Verbosity 1 outputs connection 5859 | information, a timestamp, relay_log_file, relay_log_pos, and last_errno. 5860 | Verbosity 2 adds last_error. See also L<"--error-length">. Verbosity 3 prints 5861 | the current sleep time each time pt-slave-restart sleeps. 5862 | 5863 | =item --version 5864 | 5865 | Show version and exit. 5866 | 5867 | =item --[no]version-check 5868 | 5869 | default: yes 5870 | 5871 | Check for the latest version of Percona Toolkit, MySQL, and other programs. 5872 | 5873 | This is a standard "check for updates automatically" feature, with two 5874 | additional features. First, the tool checks the version of other programs 5875 | on the local system in addition to its own version. For example, it checks 5876 | the version of every MySQL server it connects to, Perl, and the Perl module 5877 | DBD::mysql. Second, it checks for and warns about versions with known 5878 | problems. For example, MySQL 5.5.25 had a critical bug and was re-released 5879 | as 5.5.25a. 5880 | 5881 | Any updates or known problems are printed to STDOUT before the tool's normal 5882 | output. This feature should never interfere with the normal operation of the 5883 | tool. 5884 | 5885 | For more information, visit L. 5886 | 5887 | =back 5888 | 5889 | Show version and exit. 5890 | 5891 | =head1 DSN OPTIONS 5892 | 5893 | These DSN options are used to create a DSN. Each option is given like 5894 | C. The options are case-sensitive, so P and p are not the 5895 | same option. There cannot be whitespace before or after the C<=> and 5896 | if the value contains whitespace it must be quoted. DSN options are 5897 | comma-separated. See the L manpage for full details. 5898 | 5899 | =over 5900 | 5901 | =item * A 5902 | 5903 | dsn: charset; copy: yes 5904 | 5905 | Default character set. 5906 | 5907 | =item * D 5908 | 5909 | dsn: database; copy: yes 5910 | 5911 | Default database. 5912 | 5913 | =item * F 5914 | 5915 | dsn: mysql_read_default_file; copy: yes 5916 | 5917 | Only read default options from the given file 5918 | 5919 | =item * h 5920 | 5921 | dsn: host; copy: yes 5922 | 5923 | Connect to host. 5924 | 5925 | =item * p 5926 | 5927 | dsn: password; copy: yes 5928 | 5929 | Password to use when connecting. 5930 | If password contains commas they must be escaped with a backslash: "exam\,ple" 5931 | 5932 | =item * P 5933 | 5934 | dsn: port; copy: yes 5935 | 5936 | Port number to use for connection. 5937 | 5938 | =item * S 5939 | 5940 | dsn: mysql_socket; copy: yes 5941 | 5942 | Socket file to use for connection. 5943 | 5944 | =item * u 5945 | 5946 | dsn: user; copy: yes 5947 | 5948 | User for login if not current user. 5949 | 5950 | =back 5951 | 5952 | =head1 ENVIRONMENT 5953 | 5954 | The environment variable C enables verbose debugging output to STDERR. 5955 | To enable debugging and capture all output to a file, run the tool like: 5956 | 5957 | PTDEBUG=1 pt-slave-restart ... > FILE 2>&1 5958 | 5959 | Be careful: debugging output is voluminous and can generate several megabytes 5960 | of output. 5961 | 5962 | =head1 SYSTEM REQUIREMENTS 5963 | 5964 | You need Perl, DBI, DBD::mysql, and some core packages that ought to be 5965 | installed in any reasonably new version of Perl. 5966 | 5967 | =head1 BUGS 5968 | 5969 | For a list of known bugs, see L. 5970 | 5971 | Please report bugs at L. 5972 | Include the following information in your bug report: 5973 | 5974 | =over 5975 | 5976 | =item * Complete command-line used to run the tool 5977 | 5978 | =item * Tool L<"--version"> 5979 | 5980 | =item * MySQL version of all servers involved 5981 | 5982 | =item * Output from the tool including STDERR 5983 | 5984 | =item * Input files (log/dump/config files, etc.) 5985 | 5986 | =back 5987 | 5988 | If possible, include debugging output by running the tool with C; 5989 | see L<"ENVIRONMENT">. 5990 | 5991 | =head1 DOWNLOADING 5992 | 5993 | Visit L to download the 5994 | latest release of Percona Toolkit. Or, get the latest release from the 5995 | command line: 5996 | 5997 | wget percona.com/get/percona-toolkit.tar.gz 5998 | 5999 | wget percona.com/get/percona-toolkit.rpm 6000 | 6001 | wget percona.com/get/percona-toolkit.deb 6002 | 6003 | You can also get individual tools from the latest release: 6004 | 6005 | wget percona.com/get/TOOL 6006 | 6007 | Replace C with the name of any tool. 6008 | 6009 | =head1 AUTHORS 6010 | 6011 | Baron Schwartz 6012 | 6013 | =head1 ABOUT PERCONA TOOLKIT 6014 | 6015 | This tool is part of Percona Toolkit, a collection of advanced command-line 6016 | tools for MySQL developed by Percona. Percona Toolkit was forked from two 6017 | projects in June, 2011: Maatkit and Aspersa. Those projects were created by 6018 | Baron Schwartz and primarily developed by him and Daniel Nichter. Visit 6019 | L to learn about other free, open-source 6020 | software from Percona. 6021 | 6022 | =head1 COPYRIGHT, LICENSE, AND WARRANTY 6023 | 6024 | This program is copyright 2011-2015 Percona LLC and/or its affiliates, 6025 | 2007-2011 Baron Schwartz. 6026 | 6027 | THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 6028 | WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 6029 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 6030 | 6031 | This program is free software; you can redistribute it and/or modify it under 6032 | the terms of the GNU General Public License as published by the Free Software 6033 | Foundation, version 2; OR the Perl Artistic License. On UNIX and similar 6034 | systems, you can issue `man perlgpl' or `man perlartistic' to read these 6035 | licenses. 6036 | 6037 | You should have received a copy of the GNU General Public License along with 6038 | this program; if not, write to the Free Software Foundation, Inc., 59 Temple 6039 | Place, Suite 330, Boston, MA 02111-1307 USA. 6040 | 6041 | =head1 VERSION 6042 | 6043 | pt-slave-restart 2.2.15 6044 | 6045 | =cut 6046 | --------------------------------------------------------------------------------