diff --git a/bin/pt-archiver b/bin/pt-archiver index 8cc2558b..d4e3e7be 100755 --- a/bin/pt-archiver +++ b/bin/pt-archiver @@ -4685,271 +4685,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -4973,13 +4872,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -5006,23 +4971,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -5046,8 +4996,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -5056,11 +5024,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -5077,28 +5043,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -5174,7 +5121,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -5184,47 +5131,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -5247,7 +5193,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-config-diff b/bin/pt-config-diff index cb7b55bd..cb64da6a 100755 --- a/bin/pt-config-diff +++ b/bin/pt-config-diff @@ -4359,271 +4359,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -4647,13 +4546,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -4680,23 +4645,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4720,8 +4670,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4730,11 +4698,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -4751,28 +4717,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -4848,7 +4795,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -4858,47 +4805,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -4921,7 +4867,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-deadlock-logger b/bin/pt-deadlock-logger index 57f77005..aab5537f 100755 --- a/bin/pt-deadlock-logger +++ b/bin/pt-deadlock-logger @@ -3275,271 +3275,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -3563,13 +3462,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -3596,23 +3561,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -3636,8 +3586,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -3646,11 +3614,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -3667,28 +3633,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -3764,7 +3711,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -3774,47 +3721,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -3837,7 +3783,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-diskstats b/bin/pt-diskstats index 044eb3ff..48a3ad25 100755 --- a/bin/pt-diskstats +++ b/bin/pt-diskstats @@ -4170,271 +4170,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -4458,13 +4357,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -4491,23 +4456,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4531,8 +4481,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4541,11 +4509,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -4562,28 +4528,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -4659,7 +4606,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -4669,47 +4616,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -4732,7 +4678,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-duplicate-key-checker b/bin/pt-duplicate-key-checker index 909e080e..01de6cac 100755 --- a/bin/pt-duplicate-key-checker +++ b/bin/pt-duplicate-key-checker @@ -4031,271 +4031,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -4319,13 +4218,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -4352,23 +4317,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4392,8 +4342,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4402,11 +4370,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -4423,28 +4389,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -4520,7 +4467,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -4530,47 +4477,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -4593,7 +4539,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-find b/bin/pt-find index 58b126f8..12852536 100755 --- a/bin/pt-find +++ b/bin/pt-find @@ -2843,271 +2843,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -3131,13 +3030,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -3164,23 +3129,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -3204,8 +3154,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -3214,11 +3182,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -3235,28 +3201,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -3332,7 +3279,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -3342,47 +3289,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -3405,7 +3351,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-fk-error-logger b/bin/pt-fk-error-logger index 8f9a724e..6a1c59b8 100755 --- a/bin/pt-fk-error-logger +++ b/bin/pt-fk-error-logger @@ -2785,271 +2785,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -3073,13 +2972,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -3106,23 +3071,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -3146,8 +3096,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -3156,11 +3124,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -3177,28 +3143,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -3274,7 +3221,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -3284,47 +3231,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -3347,7 +3293,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-heartbeat b/bin/pt-heartbeat index 4e9cda7f..86fdce78 100755 --- a/bin/pt-heartbeat +++ b/bin/pt-heartbeat @@ -4011,271 +4011,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -4299,13 +4198,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -4332,23 +4297,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4372,8 +4322,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4382,11 +4350,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -4403,28 +4369,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -4500,7 +4447,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -4510,47 +4457,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -4573,7 +4519,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-index-usage b/bin/pt-index-usage index dd4ac9a3..acf0cccf 100755 --- a/bin/pt-index-usage +++ b/bin/pt-index-usage @@ -5486,271 +5486,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -5774,13 +5673,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -5807,23 +5772,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -5847,8 +5797,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -5857,11 +5825,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -5878,28 +5844,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -5975,7 +5922,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -5985,47 +5932,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -6048,7 +5994,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-kill b/bin/pt-kill index 9a0206a7..cab0144d 100755 --- a/bin/pt-kill +++ b/bin/pt-kill @@ -5708,271 +5708,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -5996,13 +5895,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -6029,23 +5994,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -6069,8 +6019,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -6079,11 +6047,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -6100,28 +6066,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -6197,7 +6144,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -6207,47 +6154,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -6270,7 +6216,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-online-schema-change b/bin/pt-online-schema-change index c12a26a5..1145a692 100755 --- a/bin/pt-online-schema-change +++ b/bin/pt-online-schema-change @@ -7158,271 +7158,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -7446,13 +7345,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -7479,23 +7444,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -7519,8 +7469,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -7529,11 +7497,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -7550,28 +7516,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -7647,7 +7594,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -7657,47 +7604,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -7720,7 +7666,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-query-advisor b/bin/pt-query-advisor index 23d66fdb..cd3e9145 100755 --- a/bin/pt-query-advisor +++ b/bin/pt-query-advisor @@ -7441,271 +7441,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -7729,13 +7628,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -7762,23 +7727,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -7802,8 +7752,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -7812,11 +7780,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -7833,28 +7799,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -7930,7 +7877,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -7940,47 +7887,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -8003,7 +7949,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-query-digest b/bin/pt-query-digest index 5af54d30..36c19e34 100755 --- a/bin/pt-query-digest +++ b/bin/pt-query-digest @@ -13070,271 +13070,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -13358,13 +13257,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -13391,23 +13356,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -13431,8 +13381,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -13441,11 +13409,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -13462,28 +13428,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -13559,7 +13506,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -13569,47 +13516,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -13632,7 +13578,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; @@ -17093,7 +17039,7 @@ distinct checksums are treated as equal. Show version and exit. -tem --[no]version-check +=item --[no]version-check default: yes diff --git a/bin/pt-slave-delay b/bin/pt-slave-delay index 8e672a11..8daab2c3 100755 --- a/bin/pt-slave-delay +++ b/bin/pt-slave-delay @@ -3386,271 +3386,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -3674,13 +3573,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -3707,23 +3672,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -3747,8 +3697,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -3757,11 +3725,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -3778,28 +3744,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -3875,7 +3822,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -3885,47 +3832,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -3948,7 +3894,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-slave-restart b/bin/pt-slave-restart index 5a08fa10..8cad2e69 100755 --- a/bin/pt-slave-restart +++ b/bin/pt-slave-restart @@ -4010,271 +4010,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -4298,13 +4197,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -4331,23 +4296,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4371,8 +4321,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4381,11 +4349,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -4402,28 +4368,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -4499,7 +4446,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -4509,47 +4456,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -4572,7 +4518,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-table-checksum b/bin/pt-table-checksum index 820d85da..a5d2035f 100755 --- a/bin/pt-table-checksum +++ b/bin/pt-table-checksum @@ -724,271 +724,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -1012,13 +911,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -1045,23 +1010,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -1085,8 +1035,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -1095,11 +1063,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -1116,28 +1082,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -1213,7 +1160,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -1223,47 +1170,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -1286,7 +1232,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-table-sync b/bin/pt-table-sync index a50900c9..96549837 100755 --- a/bin/pt-table-sync +++ b/bin/pt-table-sync @@ -8848,271 +8848,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -9136,13 +9035,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -9169,23 +9134,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -9209,8 +9159,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -9219,11 +9187,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -9240,28 +9206,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -9337,7 +9284,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -9347,47 +9294,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -9410,7 +9356,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-upgrade b/bin/pt-upgrade index 50b3087d..9d221ee2 100755 --- a/bin/pt-upgrade +++ b/bin/pt-upgrade @@ -11667,271 +11667,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -11955,13 +11854,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -11988,23 +11953,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -12028,8 +11978,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -12038,11 +12006,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -12059,28 +12025,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -12156,7 +12103,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -12166,47 +12113,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -12229,7 +12175,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/bin/pt-variable-advisor b/bin/pt-variable-advisor index 9fb9c7f1..5f91ae38 100755 --- a/bin/pt-variable-advisor +++ b/bin/pt-variable-advisor @@ -4293,271 +4293,170 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { { package VersionCheck; + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + + sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; - } + push @$instances, { name => 'system', id => 0 }; + + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } + if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; - - return unless $response->{content}; - - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; my $sql = q{SELECT CONCAT(@@hostname, @@port)}; PTDEBUG && _d($sql); @@ -4581,13 +4480,79 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + return unless $response->{content}; + + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -4614,23 +4579,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4654,8 +4604,26 @@ sub parse_server_response { return \%items; } +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -4664,11 +4632,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -4685,28 +4651,9 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -4782,7 +4729,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -4792,47 +4739,46 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -4855,7 +4801,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/lib/VersionCheck.pm b/lib/VersionCheck.pm index 58b57e9f..a7e96e32 100644 --- a/lib/VersionCheck.pm +++ b/lib/VersionCheck.pm @@ -20,323 +20,207 @@ { package VersionCheck; +# NOTE: VersionCheck 2.2 is not compatible with 2.1. +# In 2.1, the vc file did not have a special system +# instance with ID 0, and it used the file's mtime. +# In 2.2, the system and MySQL instances are all saved +# in the vc file, and the file's mtime doesn't matter. + use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; -use Data::Dumper qw(); +use Data::Dumper; +local $Data::Dumper::Indent = 1; +local $Data::Dumper::Sortkeys = 1; +local $Data::Dumper::Quotekeys = 0; + use Digest::MD5 qw(md5_hex); use Sys::Hostname qw(hostname); -use Fcntl qw(:DEFAULT); use File::Basename qw(); use File::Spec; -my $dir = File::Spec->tmpdir(); -my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check'); -my $check_time_limit = 60 * 60 * 24; # one day - -sub Dumper { - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Quotekeys = 0; - - Data::Dumper::Dumper(@_); -} - -local $EVAL_ERROR; eval { require Percona::Toolkit; require HTTPMicro; }; +# Return the version check file used to keep track of +# MySQL instance that have been checked and when. +sub version_check_file { + return File::Spec->catfile( + File::Spec->tmpdir(), + 'percona-version-check-2.2' + ); +} + +# Return time limit between checks. +sub version_check_time_limit { + return 60 * 60 * 24; # one day +} + +# ############################################################################# +# Version check handlers +# ############################################################################# + +# Do a version check. This is only sub a caller/tool needs to call. +# Pass in an arrayref of hashrefs for each MySQL instance to check. +# Each hashref should have a dbh and a dsn. +# +# This sub fails silently, so you must use PTDEBUG to diagnose. Use +# PTDEBUG_VERSION_CHECK=1 and this sub will exit 255 when it's done +# (helpful in combination with PTDEBUG=1 so you don't get the tool's +# full debug output). +# +# Use PERCONA_VERSION_CHECK_URL to set the version check API url, +# e.g. https://stage.v.percona.com for testing. sub version_check { - my %args = @_; - my @instances = $args{instances} ? @{ $args{instances} } : (); - # If this blows up, oh well, don't bother the user about it. - # This feature is a "best effort" only; we don't want it to - # get in the way of the tool's real work. - - if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { - warn '--version-check is disabled by the PERCONA_VERSION_CHECK ', - "environment variable.\n\n"; - return; - } - - # we got here if the protocol wasn't "off", and the values - # were validated earlier, so just handle auto - # This line is mostly here for the test suite: - $args{protocol} ||= 'https'; - my @protocols = $args{protocol} eq 'auto' - ? qw(https http) - : $args{protocol}; - - my $instances_to_check = []; - my $time = int(time()); + my (%args) = @_; eval { - # Name and ID the instances. The name is for debugging; the ID is - # what the code uses. - foreach my $instance ( @instances ) { - my ($name, $id) = _generate_identifier($instance); + my $instances = $args{instances} || []; + + if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) { + PTDEBUG && _d('--version-check disabled by PERCONA_VERSION_CHECK=0'); + return; + } + + # Name and ID the instances. The name is for debugging, + # and the ID is what the code uses to prevent double-checking. + foreach my $instance ( @$instances ) { + my ($name, $id) = get_instance_id($instance); $instance->{name} = $name; $instance->{id} = $id; } - my $time_to_check; - ($time_to_check, $instances_to_check) - = time_to_check($check_time_file, \@instances, $time); - if ( !$time_to_check ) { - warn 'It is not time to --version-check again; ', - "only 1 check per day.\n\n"; - return; + # Push a special instance for the system itself. + push @$instances, { name => 'system', id => 0 }; + + # Get the instances which haven't been checked in the 24 hours. + my $instances_to_check = get_instances_to_check( + instances => $instances, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); + PTDEBUG && _d(scalar @$instances_to_check, 'instances to check'); + return unless @$instances_to_check; + + # Get the list of program to check from Percona. Try using + # https first; fallback to http if that fails (probably because + # IO::Socket::SSL isn't installed). + my $advice; + PROTOCOL: + foreach my $protocol ( qw(https http) ) { + $advice = eval { + pingback( + instances => $instances_to_check, + protocol => $protocol, + url => $args{url} # testing + || $ENV{PERCONA_VERSION_CHECK_URL} # testing + || "$protocol://v.percona.com", + ); + }; + last PROTOCOL unless $EVAL_ERROR; + PTDEBUG && _d('--version-check error:', $EVAL_ERROR); } - my $advice; - my $e; - for my $protocol ( @protocols ) { - $advice = eval { pingback( - url => $ENV{PERCONA_VERSION_CHECK_URL} || "$protocol://v.percona.com", - instances => $instances_to_check, - protocol => $protocol, - ) }; - # No advice, and no error, so no reason to keep trying. - last if !$advice && !$EVAL_ERROR; - $e ||= $EVAL_ERROR; - } if ( $advice ) { - print "# Percona suggests these upgrades:\n"; + PTDEBUG && _d('Advice:', Dumper($advice)); + if ( scalar @$advice > 1) { + print "\n# " . scalar @$advice . " software updates are " + . "available:\n"; + } + else { + print "\n# A software update is available:\n"; + } print join("\n", map { "# * $_" } @$advice), "\n\n"; } - else { - die $e if $e; - print "# No suggestions at this time.\n\n"; - ($ENV{PTVCDEBUG} || PTDEBUG ) - && _d('--version-check worked, but there were no suggestions'); - } + + # Update the check time for things we checked. I.e. if we + # didn't check it, do _not_ update its time. + update_check_times( + instances => $instances_to_check, + vc_file => $args{vc_file}, # testing + now => $args{now}, # testing + ); }; if ( $EVAL_ERROR ) { - warn "Error doing --version-check: $EVAL_ERROR"; + PTDEBUG && _d('--version-check failed:', $EVAL_ERROR); } - else { - update_checks_file($check_time_file, $instances_to_check, $time); + + if ( $ENV{PTDEBUG_VERSION_CHECK} ) { + warn "Exiting because the PTDEBUG_VERSION_CHECK " + . "environment variable is defined.\n"; + exit 255; } - + return; } -sub pingback { +sub get_instances_to_check { my (%args) = @_; - my @required_args = qw(url); - foreach my $arg ( @required_args ) { - die "I need a $arg arugment" unless $args{$arg}; - } - my ($url) = @args{@required_args}; - # Optional args - my ($instances, $ua) = @args{qw(instances ua)}; + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); - $ua ||= HTTPMicro->new( timeout => 5 ); - - # GET https://upgrade.percona.com, the server will return - # a plaintext list of items/programs it wants the tool - # to get, one item per line with the format ITEM;TYPE[;VARS] - # ITEM is the pretty name of the item/program; TYPE is - # the type of ITEM that helps the tool determine how to - # get the item's version; and VARS is optional for certain - # items/types that need extra hints. - my $response = $ua->request('GET', $url); - ($ENV{PTVCDEBUG} || PTDEBUG) && _d('Server response:', Dumper($response)); - die "No response from GET $url" - if !$response; - die("GET on $url returned HTTP status $response->{status}; expected 200\n", - ($response->{content} || '')) if $response->{status} != 200; - die("GET on $url did not return any programs to check") - if !$response->{content}; - - # Parse the plaintext server response into a hashref keyed on - # the items like: - # "MySQL" => { - # item => "MySQL", - # type => "mysql_variables", - # vars => ["version", "version_comment"], - # } - my $items = __PACKAGE__->parse_server_response( - response => $response->{content} - ); - die "Failed to parse server requested programs: $response->{content}" - if !scalar keys %$items; - - # Get the versions for those items in another hashref also keyed on - # the items like: - # "MySQL" => "MySQL Community Server 5.1.49-log", - my $versions = __PACKAGE__->get_versions( - items => $items, - instances => $instances, - ); - die "Failed to get any program versions; should have at least gotten Perl" - if !scalar keys %$versions; - - # Join the items and whatever versions are available and re-encode - # them in same simple plaintext item-per-line protocol, and send - # it back to Percona. - my $client_content = encode_client_response( - items => $items, - versions => $versions, - general_id => md5_hex( hostname() ), - ); - - my $client_response = { - headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, - content => $client_content, - }; - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Client response:', Dumper($client_response)); + if ( !-f $vc_file ) { + PTDEBUG && _d($vc_file, 'does not exist; version checking all instances'); + return $instances; } - $response = $ua->request('POST', $url, $client_response); - PTDEBUG && _d('Server suggestions:', Dumper($response)); - die "No response from POST $url $client_response" - if !$response; - die "POST $url returned HTTP status $response->{status}; expected 200" - if $response->{status} != 200; + # The version check file contains "ID,time" lines for each MySQL instance + # and a special "0,time" instance for the system. Another tool may have + # seen fewer or more instances than the current tool, but we'll read them + # all and check only the instances for the current tool. + open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR"; + chomp(my $file_contents = do { local $/ = undef; <$fh> }); + PTDEBUG && _d($vc_file, 'contents:', $file_contents); + close $fh; + my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg; - # If the server does not have any suggestions, - # there will not be any content. - return unless $response->{content}; - - # If the server has suggestions for items, it sends them back in - # the same format: ITEM:TYPE:SUGGESTION\n. ITEM:TYPE is mostly for - # debugging; the tool just repports the suggestions. - $items = __PACKAGE__->parse_server_response( - response => $response->{content}, - split_vars => 0, - ); - die "Failed to parse server suggestions: $response->{content}" - if !scalar keys %$items; - my @suggestions = map { $_->{vars} } - sort { $a->{item} cmp $b->{item} } - values %$items; - - return \@suggestions; -} - -sub time_to_check { - my ($file, $instances, $time) = @_; - die "I need a file argument" unless $file; - $time ||= int(time()); # current time - - # If we have MySQL instances, check only the ones that haven't been - # seen/checked before or were check > 24 hours ago. - if ( @$instances ) { - my $instances_to_check = instances_to_check($file, $instances, $time); - return scalar @$instances_to_check, $instances_to_check; - } - - return 1 if !-f $file; - - # No MySQL instances (happens with tools like pt-diskstats), so just - # check the file's mtime and check if it was updated > 24 hours ago. - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - PTDEBUG && _d('Error getting modified time of', $file); - return 1; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - return 1; - } - - # File was updated less than a day ago; don't check yet. - return 0; -} - -sub instances_to_check { - my ($file, $instances, $time, %args) = @_; - - # The time limit file contains "ID,time" lines for each MySQL instance - # that the last tool connected to. The last tool may have seen fewer - # or more MySQL instances than the current tool, but we'll read them - # all and check only the MySQL instances for the current tool. - my $file_contents = ''; - if (open my $fh, '<', $file) { - chomp($file_contents = do { local $/ = undef; <$fh> }); - close $fh; - } - my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg; - - # Check the MySQL instances that have either 1) never been checked - # (or seen) before, or 2) were check > 24 hours ago. + # Check the instances that have either 1) never been checked + # (or seen) before, or 2) were checked > check time limit ago. + my $check_time_limit = version_check_time_limit(); my @instances_to_check; foreach my $instance ( @$instances ) { - my $mtime = $cached_instances{ $instance->{id} }; - if ( !$mtime || (($time - $mtime) > $check_time_limit) ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Time to check MySQL instance', $instance->{name}); - } + my $last_check_time = $last_check_time_for{ $instance->{id} }; + PTDEBUG && _d('Intsance', $instance->{id}, 'last checked', + $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0)); + if ( !defined $last_check_time + || ($now - $last_check_time) >= $check_time_limit ) { + PTDEBUG && _d('Time to check', Dumper($instance)); push @instances_to_check, $instance; - $cached_instances{ $instance->{id} } = $time; } } - if ( $args{update_file} ) { - # Overwrite the time limit file with the check times for instances - # we're going to check or with the original check time for instances - # that we're still waiting on. - open my $fh, '>', $file or die "Cannot open $file for writing: $OS_ERROR"; - while ( my ($id, $time) = each %cached_instances ) { - print { $fh } "$id,$time\n"; - } - close $fh or die "Cannot close $file: $OS_ERROR"; - } - return \@instances_to_check; } -sub update_checks_file { - my ($file, $instances, $time) = @_; +sub update_check_times { + my (%args) = @_; - # If there's no time limit file, then create it, but - # don't return yet, let _time_to_check_by_instances() write any MySQL - # instances to the file, then return. - if ( !-f $file ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Creating time limit file', $file); - } - _touch($file); - } + my $instances = $args{instances}; + my $now = $args{now} || int(time); + my $vc_file = $args{vc_file} || version_check_file(); + PTDEBUG && _d('Updating last check time:', $now); - if ( $instances && @$instances ) { - instances_to_check($file, $instances, $time, update_file => 1); - return; - } - - my $mtime = (stat $file)[9]; - if ( !defined $mtime ) { - _touch($file); - return; - } - PTDEBUG && _d('time=', $time, 'mtime=', $mtime); - if ( ($time - $mtime) > $check_time_limit ) { - _touch($file); - return; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + foreach my $instance ( sort { $a->{id} <=> $b->{id} } @$instances ) { + PTDEBUG && _d('Updated:', Dumper($instance)); + print { $fh } $instance->{id} . ',' . $now . "\n"; } + close $fh; return; } -sub _touch { - my ($file) = @_; - sysopen my $fh, $file, O_WRONLY|O_CREAT - or die "Cannot create $file : $!"; - close $fh or die "Cannot close $file : $!"; - utime(undef, undef, $file); -} +sub get_instance_id { + my ($instance) = @_; -sub _generate_identifier { - my $instance = shift; - my $dbh = $instance->{dbh}; - my $dsn = $instance->{dsn}; + my $dbh = $instance->{dbh}; + my $dsn = $instance->{dsn}; # MySQL 5.1+ has @@hostname and @@port # MySQL 5.0 has @@hostname but port only in SHOW VARS @@ -366,13 +250,107 @@ sub _generate_identifier { } my $id = md5_hex($name); - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('MySQL instance', $name, 'is', $id); - } + PTDEBUG && _d('MySQL instance', $name, 'is', $id); return $name, $id; } +# ############################################################################# +# Protocol handlers +# ############################################################################# + +sub pingback { + my (%args) = @_; + my @required_args = qw(url instances); + foreach my $arg ( @required_args ) { + die "I need a $arg arugment" unless $args{$arg}; + } + my $url = $args{url}; + my $instances = $args{instances}; + + # Optional args + my $ua = $args{ua} || HTTPMicro->new( timeout => 5 ); + + # GET https://upgrade.percona.com, the server will return + # a plaintext list of items/programs it wants the tool + # to get, one item per line with the format ITEM;TYPE[;VARS] + # ITEM is the pretty name of the item/program; TYPE is + # the type of ITEM that helps the tool determine how to + # get the item's version; and VARS is optional for certain + # items/types that need extra hints. + my $response = $ua->request('GET', $url); + PTDEBUG && _d('Server response:', Dumper($response)); + die "No response from GET $url" + if !$response; + die("GET on $url returned HTTP status $response->{status}; expected 200\n", + ($response->{content} || '')) if $response->{status} != 200; + die("GET on $url did not return any programs to check") + if !$response->{content}; + + # Parse the plaintext server response into a hashref keyed on + # the items like: + # "MySQL" => { + # item => "MySQL", + # type => "mysql_variables", + # vars => ["version", "version_comment"], + # } + my $items = parse_server_response( + response => $response->{content} + ); + die "Failed to parse server requested programs: $response->{content}" + if !scalar keys %$items; + + # Get the versions for those items in another hashref also keyed on + # the items like: + # "MySQL" => "MySQL Community Server 5.1.49-log", + my $versions = get_versions( + items => $items, + instances => $instances, + ); + die "Failed to get any program versions; should have at least gotten Perl" + if !scalar keys %$versions; + + # Join the items and whatever versions are available and re-encode + # them in same simple plaintext item-per-line protocol, and send + # it back to Percona. + my $client_content = encode_client_response( + items => $items, + versions => $versions, + general_id => md5_hex( hostname() ), + ); + + my $client_response = { + headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) }, + content => $client_content, + }; + PTDEBUG && _d('Client response:', Dumper($client_response)); + + $response = $ua->request('POST', $url, $client_response); + PTDEBUG && _d('Server suggestions:', Dumper($response)); + die "No response from POST $url $client_response" + if !$response; + die "POST $url returned HTTP status $response->{status}; expected 200" + if $response->{status} != 200; + + # Response contents is empty if the server doesn't have any suggestions. + return unless $response->{content}; + + # If the server has suggestions for items, it sends them back in + # the same format: ITEM:TYPE:SUGGESTION\n. ITEM:TYPE is mostly for + # debugging; the tool just repports the suggestions. + $items = parse_server_response( + response => $response->{content}, + split_vars => 0, + ); + die "Failed to parse server suggestions: $response->{content}" + if !scalar keys %$items; + my @suggestions = map { $_->{vars} } + sort { $a->{item} cmp $b->{item} } + values %$items; + + return \@suggestions; +} + sub encode_client_response { my (%args) = @_; my @required_args = qw(items versions general_id); @@ -404,24 +382,8 @@ sub encode_client_response { return $client_response; } -sub validate_options { - my ($o) = @_; - - # No need to validate anything if we didn't get an explicit v-c - return if !$o->got('version-check'); - - my $value = $o->get('version-check'); - my @values = split /, /, - $o->read_para_after(__FILE__, qr/MAGIC_version_check/); - chomp(@values); - - return if grep { $value eq $_ } @values; - $o->save_error("--version-check invalid value $value. Accepted values are " - . join(", ", @values[0..$#values-1]) . " and $values[-1]" ); -} - sub parse_server_response { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(response); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -445,8 +407,27 @@ sub parse_server_response { return \%items; } +# Safety check: only these types of items are valid/official. +my %sub_for_type = ( + os_version => \&get_os_version, + perl_version => \&get_perl_version, + perl_module_version => \&get_perl_module_version, + mysql_variable => \&get_mysql_variable, + bin_version => \&get_bin_version, +); + +sub valid_item { + my ($item) = @_; + return unless $item; + if ( !exists $sub_for_type{ $item->{type} } ) { + PTDEBUG && _d('Invalid type:', $item->{type}); + return 0; + } + return 1; +} + sub get_versions { - my ($self, %args) = @_; + my (%args) = @_; my @required_args = qw(items); foreach my $arg ( @required_args ) { die "I need a $arg arugment" unless $args{$arg}; @@ -455,11 +436,9 @@ sub get_versions { my %versions; foreach my $item ( values %$items ) { - next unless $self->valid_item($item); - + next unless valid_item($item); eval { - my $func = 'get_' . $item->{type}; - my $version = $self->$func( + my $version = $sub_for_type{ $item->{type} }->( item => $item, instances => $args{instances}, ); @@ -476,28 +455,12 @@ sub get_versions { return \%versions; } -sub valid_item { - my ($self, $item) = @_; - return unless $item; - if ( ($item->{type} || '') !~ m/ - ^(?: - os_version - |perl_version - |perl_module_version - |mysql_variable - |bin_version - )$/x ) { - PTDEBUG && _d('Invalid type:', $item->{type}); - return; - } - - return 1; -} +# ############################################################################# +# Version getters +# ############################################################################# sub get_os_version { - my ($self) = @_; - if ( $OSNAME eq 'MSWin32' ) { require Win32; return Win32::GetOSDisplayName(); @@ -574,7 +537,7 @@ sub get_os_version { } sub get_perl_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -584,7 +547,7 @@ sub get_perl_version { } sub get_perl_module_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; return unless $item; @@ -592,7 +555,7 @@ sub get_perl_module_version { # else the item name is an implicity Perl module name to which we # append ::VERSION to get the module's version. my $var = $item->{item} . '::VERSION'; - my $version = _get_scalar($var); + my $version = get_scalar($var); PTDEBUG && _d('Perl version for', $var, '=', "$version"); # Explicitly stringify this else $PERL_VERSION will return @@ -600,36 +563,35 @@ sub get_perl_module_version { return $version ? "$version" : $version; } -sub _get_scalar { +sub get_scalar { no strict; return ${*{shift()}}; } sub get_mysql_variable { - my $self = shift; - return $self->_get_from_mysql( + return get_from_mysql( show => 'VARIABLES', @_, ); } -sub _get_from_mysql { - my ($self, %args) = @_; +sub get_from_mysql { + my (%args) = @_; my $show = $args{show}; my $item = $args{item}; my $instances = $args{instances}; return unless $show && $item; if ( !$instances || !@$instances ) { - if ( $ENV{PTVCDEBUG} || PTDEBUG ) { - _d('Cannot check', $item, 'because there are no MySQL instances'); - } + PTDEBUG && _d('Cannot check', $item, + 'because there are no MySQL instances'); return; } my @versions; my %version_for; foreach my $instance ( @$instances ) { + next unless $instance->{id}; # special system instance has id=0 my $dbh = $instance->{dbh}; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sql = qq/SHOW $show/; @@ -652,7 +614,7 @@ sub _get_from_mysql { } sub get_bin_version { - my ($self, %args) = @_; + my (%args) = @_; my $item = $args{item}; my $cmd = $item->{item}; return unless $cmd; diff --git a/t/lib/VersionCheck.t b/t/lib/VersionCheck.t index 1323f577..758a1f0d 100644 --- a/t/lib/VersionCheck.t +++ b/t/lib/VersionCheck.t @@ -25,12 +25,10 @@ my $sb = new Sandbox(basedir => '/tmp', DSNParser => $dp); my $master_dbh = $sb->get_dbh_for('master'); my $slave1_dbh = $sb->get_dbh_for('slave1'); -my $vc = 'VersionCheck'; - sub test_v { my (%args) = @_; - my $items = $vc->parse_server_response( + my $items = VersionCheck::parse_server_response( response => $args{response}, ); is_deeply( @@ -39,7 +37,7 @@ sub test_v { "$args{name} items" ); - my $versions = $vc->get_versions( + my $versions = VersionCheck::get_versions( items => $items, instances => [ { @@ -119,9 +117,8 @@ test_v( }, ); -use File::Spec; { - local $ENV{PATH} = File::Spec->catfile($ENV{PERCONA_TOOLKIT_BRANCH}, "bin") . ":$ENV{PATH}"; + local $ENV{PATH} = "$ENV{PATH}:$trunk/bin"; test_v( name => "bin_version", response => "pt-archiver;bin_version\n", @@ -169,7 +166,7 @@ SKIP: { # since the test env doesn't know what OS its running on. We # at least know that an OS should have these two things: a word # and version with at least major and minor numbers. -my $os = $vc->get_os_version; +my $os = VersionCheck::get_os_version(); like( $os, @@ -195,7 +192,7 @@ ok( # Validate items # ############################################################################# -my $versions = $vc->get_versions( +my $versions = VersionCheck::get_versions( items => { 'Foo' => { item => 'Foo', @@ -226,9 +223,9 @@ if ( $master_dbh ) { (undef, $mysql_distro) = $master_dbh->selectrow_array("SHOW VARIABLES LIKE 'version_comment'"); - (undef, $master_id) = VersionCheck::_generate_identifier( + (undef, $master_id) = VersionCheck::get_instance_id( { dbh => $master_dbh, dsn => { h => '127.1', P => 12345 }}); - (undef, $slave1_id) = VersionCheck::_generate_identifier( + (undef, $slave1_id) = VersionCheck::get_instance_id( { dbh => $slave1_dbh, dsn => { h => '127.1', P => 12346 }}); $master_inst = { @@ -281,7 +278,7 @@ sub test_pingback { eval { $sug = VersionCheck::pingback( url => $url, - instances => $args{instances}, + instances => $args{instances} || [], ua => $fake_ua, ); }; @@ -290,7 +287,7 @@ sub test_pingback { eval { $sug = VersionCheck::pingback( url => $url, - instances => $args{instances}, + instances => $args{instances} || [], ua => $fake_ua, ); }; @@ -463,86 +460,104 @@ SKIP: { } # ############################################################################# -# Testing time_to_check +# get_instances_to_check() # ############################################################################# -my $dir = File::Spec->tmpdir(); -my $file = File::Spec->catfile($dir, 'percona-toolkit-version-check-test'); +my $vc_file = VersionCheck::version_check_file(); +unlink $vc_file if -f $vc_file; +PerconaTest::wait_until( sub { !-f $vc_file } ); -unlink $file if -f $file; +my $now = 100000; # a fake Unix ts works -my $time = int(time()); +my $instances = []; + +sub get_check { + my (%args) = @_; + return VersionCheck::get_instances_to_check( + instances => $instances, + vc_file => $vc_file, + now => $args{now} || $now, + ); +} + +my $check = get_check(); + +is_deeply( + $check, + [], + "get_instances_to_check(): no instances" +) or diag(Dumper($check)); ok( - VersionCheck::time_to_check($file, [], $time), - "time_to_check returns true if the file doesn't exist", + !-f $vc_file, + "Version check file not created" +); + +# Add default system instance. version_check() does this. +push @$instances, { id => 0, name => "system" }; + +eval { + VersionCheck::update_check_times( + instances => $instances, + vc_file => $vc_file, + now => $now, + ); +}; + +is( + $EVAL_ERROR, + "", + "update_check_times(): no error" ); ok( - !-f $file, - "time_to_check doesn't create the checks file" + -f $vc_file, + "update_check_times() created version check file" ); -VersionCheck::update_checks_file($file, [], $time); +my $output = `cat $vc_file`; -ok( - -f $file, - "update_checks_file creates the checks file" +is( + $output, + "0,$now\n", + "Version check file contents" ); -ok( - !VersionCheck::time_to_check($file, [], $time), - "time_to_check is false if file exists and it's been less than 24 hours" -); +$check = get_check(); -my $one_day = 60 * 60 * 24; -my ($orig_atime, $orig_mtime) = (stat($file))[8,9]; +is_deeply( + $check, + [], + "get_instances_to_check(): no instances to check" +) or diag(Dumper($check)); -my $mod_atime = $orig_atime - $one_day * 2; -my $mod_mtime = $orig_mtime - $one_day * 2; +my $check_time_limit = VersionCheck::version_check_time_limit(); -utime($mod_atime, $mod_mtime, $file); +open my $fh, '>', $vc_file + or die "Cannot write to $vc_file: $OS_ERROR"; +print { $fh } "0,$now\n"; +close $fh; -cmp_ok( - (stat($file))[9], - q{<}, - time() - $one_day, - "The file's mtime is at least one day behind time()", -); +# You can verify this test by adding - 1 to this line, +# making it seem like the instance hasn't been checked +# in 1 second less than the limit. +$check = get_check(now => $now + $check_time_limit); -ok( - VersionCheck::time_to_check($file, [], $time), - "time_to_check true if file exists and mtime < one day" -); - -my ($atime, $mtime) = (stat($file))[8,9]; - -is($mod_atime, $atime, "time_to_check doesn't update the atime"); -is($mod_mtime, $mtime, "time_to_check doesn't update the mtime"); - -VersionCheck::update_checks_file($file, [], $time); - -($atime, $mtime) = (stat($file))[8,9]; - -ok( - $orig_atime == $atime - && $orig_mtime == $mtime, - "...but update_checks_file does" -); - -ok( - !VersionCheck::time_to_check($file, [], $time), - "...and time_to_check fails after update_checks_file" -); +is_deeply( + $check, + $instances, + "get_instances_to_check(): time to check instance" +) or diag(Dumper($check)); # ############################################################################# -# _generate_identifier +# get_instance_id # ############################################################################# is( - VersionCheck::_generate_identifier( { dbh => undef, dsn => { h => "localhost", P => 12345 } } ), + VersionCheck::get_instance_id( + { dbh => undef, dsn => { h => "localhost", P => 12345 } } ), md5_hex("localhost", 12345), - "_generate_identifier() works as expected for 4.1", + "get_instance_id() works as expected for 4.1", ); SKIP: { @@ -564,91 +579,49 @@ SKIP: { else { $expect_master_id = md5_hex("localhost", 12345); } - + is( $master_id, $expect_master_id, - "_generate_identifier() for MySQL $sandbox_version" + "get_instance_id() for MySQL $sandbox_version" ); # The time limit file already exists (see previous tests), but this is # a new MySQL instance, so it should be time to check it. - my ($is_time, $check_inst) = VersionCheck::time_to_check( - $file, - [ $master_inst ], - ); - VersionCheck::update_checks_file($file, $check_inst, int(time())); - - ok( - $is_time, - "Time to check a new MySQL instance ID", - ); + push @$instances, $master_inst; + $check = get_check(); is_deeply( - $check_inst, + $check, [ $master_inst ], - "Check just the new instance" - ); + "get_instances_to_check(): check new MySQL instance" + ) or diag(Dumper($check)); - - ($is_time, $check_inst) = VersionCheck::time_to_check( - $file, - [ $master_inst ], - ); - - VersionCheck::update_checks_file($file, $check_inst, int(time())); - - ok( - !$is_time, - "...but not the second time around", - ); - - open my $fh, q{>}, $file or die $!; - print { $fh } "$master_id," . (time() - $one_day * 2) . "\n"; + # Write vc file as if the system was checked now, but the MySQL + # instance was checked 10 hours ago. So it won't need to checked + # for another 14 hours. + my $ten_hours = 60 * 60 * 10; + my $fourteen_hours = 60 * 60 * 14; + open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR"; + print { $fh } "0,$now\n$master_id," . ($now - $ten_hours) . "\n"; close $fh; - ($is_time, $check_inst) = VersionCheck::time_to_check( - $file, - [ $master_inst ], - ); + $check = get_check(); - VersionCheck::update_checks_file($file, $check_inst, int(time())); - is_deeply( - $check_inst, - [ $master_inst ], - "...unless more than a day has gone past", - ); + $check, + [], + "get_instances_to_check(): not time to check either instance" + ) or diag(Dumper($check)); - ($is_time, $check_inst) = VersionCheck::time_to_check( - $file, - [ $master_inst, $slave1_inst ], - ); + # Pretend like those 14 hours have passed now. + $check = get_check(now => $now + $fourteen_hours); - VersionCheck::update_checks_file($file, $check_inst, int(time())); - is_deeply( - $check_inst, - [ $slave1_inst ], - "With multiple ids, time_to_check() returns only those that need checking", - ); - - ok( - $is_time, - "...and is time to check" - ); - - ($is_time, $check_inst) = VersionCheck::time_to_check( - $file, - [ $master_inst, $slave1_inst ], - ); - - VersionCheck::update_checks_file($file, $check_inst, int(time())); - - ok( - !$is_time, - "...and false if there isn't anything to check", - ); + $check, + [ $master_inst ], + "get_instances_to_check(): time to check one of two instances" + ) or diag(Dumper($check)); } # ############################################################################ @@ -656,8 +629,8 @@ SKIP: { # if the file doesn't exist. # ############################################################################# -unlink $file if -f $file; -PerconaTest::wait_until( sub { !-f $file } ); +unlink $vc_file if -f $vc_file; +PerconaTest::wait_until( sub { !-f $vc_file } ); SKIP: { skip 'Cannot connect to sandbox master', 2 unless $master_dbh; @@ -708,11 +681,11 @@ my @vc_tools = grep { chomp; basename($_) =~ /\A[a-z-]+\z/ } foreach my $tool ( @vc_tools ) { my $tool_name = basename($tool); - my $output = `$tool --version-check ftp`; + my $output = `$tool --help`; like( $output, - qr/\Q* --version-check invalid value ftp. Accepted values are https, http, auto and off/, - "$tool_name validates --version-check" + qr/^\s+--version-check\s+TRUE$/m, + "--version-check is on in $tool_name" ); }