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