v-c: Updated to identify and report every instance, and to skip instances already version-checked that day

lib/Percona/Toolkit.pm

@@ -20,6 +20,15 @@
 {
 package Percona::Toolkit;
 our $VERSION = '2.1.3';
+
+sub slurp_file {
+   my ($file) = @_;
+   open my $fh, "<", $file or die "Cannot open $file: $!";
+   my $contents = do { local $/ = undef; <$fh> };
+   close $fh;
+   return $contents;
+}
+
 1;
 }
 # ###########################################################################

lib/PerconaTest.pm

@@ -33,6 +33,8 @@ use warnings FATAL => 'all';
 use English qw(-no_match_vars);
 use constant PTDEVDEBUG => $ENV{PTDEVDEBUG} || 0;
 
+use Percona::Toolkit;
+
 use Test::More;
 use Time::HiRes qw(sleep time);
 use File::Temp qw(tempfile);
@@ -211,13 +213,7 @@ sub load_file {
    return $contents;
 }
 
-sub slurp_file {
+sub slurp_file { Percona::Toolkit::slurp_file(@_) }
-   my ($file) = @_;
-   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
-   my $contents = do { local $/ = undef; <$fh> };
-   close $fh;
-   return $contents;
-}
 
 sub parse_file {
    my ( $file, $p, $ea ) = @_;

lib/Pingback.pm

@@ -28,9 +28,11 @@ use English qw(-no_match_vars);
 
 use constant PTDEBUG => $ENV{PTDEBUG} || 0;
 
-use File::Basename qw();
 use Data::Dumper   qw();
+use Digest::MD5    qw(md5_hex);
+use Sys::Hostname  qw(hostname);
 use Fcntl          qw(:DEFAULT);
+use File::Basename qw();
 
 use File::Spec;
 
@@ -48,12 +50,13 @@ sub Dumper {
 
 local $EVAL_ERROR;
 eval {
+   require Percona::Toolkit;
    require HTTPMicro;
    require VersionCheck;
 };
 
 sub version_check {
-   my %args = @_;
+   my @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.
@@ -66,9 +69,8 @@ sub version_check {
          return;
       } 
 
-      my $dbhs          = $args{instances};
+      my %id_to_dbh  = map { _generate_identifier($_) => $_->{dbh} } @instances;
-      my %instance_ids  = map { _generate_identifier($_) => $_ } @$dbhs;
+      my $time_to_check = time_to_check($check_time_file, [ keys %id_to_dbh ]);
-      my $time_to_check = time_to_check($check_time_file, [ keys %instance_ids ]);
       if ( !$time_to_check ) {
          if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
             _d('It is not time to --version-check again;',
@@ -79,7 +81,7 @@ sub version_check {
       }
 
       my $instances_to_check = ref($time_to_check)
-                             ? { map { $_ => $instance_ids{$_} } @$time_to_check }
+                             ? { map { $_ => $id_to_dbh{$_} } @$time_to_check }
                              : {};
       my $advice = pingback(
          url       => $ENV{PERCONA_VERSION_CHECK_URL} || 'http://v.percona.com',
@@ -112,7 +114,7 @@ sub pingback {
    my ($url) = @args{@required_args};
 
    # Optional args
-   my ($dbh, $ua, $vc) = @args{qw(dbh ua VersionCheck)};
+   my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)};
 
    $ua ||= HTTPMicro->new( timeout => 2 );
    $vc ||= VersionCheck->new();
@@ -145,13 +147,13 @@ sub pingback {
    );
    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 = $vc->get_versions(
-      items => $items,
+      items     => $items,
-      dbh   => $dbh,
+      instances => $instances,
    );
    die "Failed to get any program versions; should have at least gotten Perl"
       if !scalar keys %$versions;
@@ -160,8 +162,9 @@ sub pingback {
    # them in same simple plaintext item-per-line protocol, and send
    # it back to Percona.
    my $client_content = encode_client_response(
-      items    => $items,
+      items      => $items,
-      versions => $versions,
+      versions   => $versions,
+      general_id => md5_hex( hostname() ),
    );
 
    my $client_response = {
@@ -234,8 +237,8 @@ sub _time_to_check_by_instances {
    my ($file, $instance_ids, $time) = @_;
    
    chomp(my $file_contents = Percona::Toolkit::slurp_file($file));
-   my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/g;
+   my %cached_instances = $file_contents =~ /^([^,]+),(.+)$/mg;
-
+   
    my @instances_to_check = grep {
       my $update;
       if ( my $mtime = $cached_instances{$_} ) {
@@ -271,18 +274,26 @@ sub _touch {
 }
 
 sub _generate_identifier {
-   my $dbh = shift;
+   my $instance = shift;
+   my $dbh      = $instance->{dbh};
+   my $dsn      = $instance->{dsn};
 
-   
+   my $sql  = q{SELECT MD5(CONCAT(@@hostname, @@port))};
+   my ($id) = eval { $dbh->selectrow_array($sql) };
+   if ( $EVAL_ERROR ) { # assume that it's MySQL 4.x
+      $id = md5_hex( $dsn->{h}, $dsn->{P} || 3306 );
+   }
+
+   return $id;
 }
 
 sub encode_client_response {
    my (%args) = @_;
-   my @required_args = qw(items versions);
+   my @required_args = qw(items versions general_id);
    foreach my $arg ( @required_args ) {
       die "I need a $arg arugment" unless $args{$arg};
    }
-   my ($items, $versions) = @args{@required_args};
+   my ($items, $versions, $general_id) = @args{@required_args};
 
    # There may not be a version for each item.  For example, the server
    # may have requested the "MySQL" (version) item, but if the tool
@@ -292,7 +303,15 @@ sub encode_client_response {
    my @lines;
    foreach my $item ( sort keys %$items ) {
       next unless exists $versions->{$item};
-      push @lines, join(';', $item, $versions->{$item});
+      if ( ref($versions->{$item}) eq 'HASH' ) {
+         my $mysql_versions = $versions->{$item};
+         for my $id ( keys %$mysql_versions ) {
+            push @lines, join(';', $id, $item, $mysql_versions->{$id});
+         }
+      }
+      else {
+         push @lines, join(';', $general_id, $item, $versions->{$item});
+      }
    }
 
    my $client_response = join("\n", @lines) . "\n";

lib/VersionCheck.pm

@@ -86,8 +86,8 @@ sub get_versions {
       die "I need a $arg arugment" unless $args{$arg};
    }
    my ($items) = @args{@required_args};
-   my $dbh     = $args{dbh}; # optional
+   my $instances = $args{instances};
-
+   
    my %versions;
    foreach my $item ( values %$items ) {
       next unless $self->valid_item($item);
@@ -96,10 +96,10 @@ sub get_versions {
          my $func    = 'get_' . $item->{type};
          my $version = $self->$func(
             item => $item,
-            dbh  => $dbh,
+            instances => $instances,
          );
          if ( $version ) {
-            chomp $version;
+            chomp $version unless ref($version);
             $versions{$item->{item}} = $version;
          }
       };
@@ -243,23 +243,29 @@ sub _get_from_mysql {
    my ($self, %args) = @_;
    my $show = $args{show};
    my $item = $args{item};
-   my $dbh  = $args{dbh};
+   my $instances = $args{instances};
-   return unless $show && $item && $dbh;
+   return unless $show && $item && %$instances;
 
-   local $dbh->{FetchHashKeyName} = 'NAME_lc';
+   my %version_for;
-   my $sql = qq/SHOW $show/;
+   for my $id ( keys %$instances ) {
-   PTDEBUG && _d($sql);
+      my $dbh = $instances->{$id};
-   my $rows = $dbh->selectall_hashref($sql, 'variable_name');
+      local $dbh->{FetchHashKeyName} = 'NAME_lc';
+      my $sql = qq/SHOW $show/;
+      PTDEBUG && _d($sql);
+      my $rows = $dbh->selectall_hashref($sql, 'variable_name');
 
-   my @versions;
+      my @versions;
-   foreach my $var ( @{$item->{vars}} ) {
+      foreach my $var ( @{$item->{vars}} ) {
-      $var = lc($var);
+         $var = lc($var);
-      my $version = $rows->{$var}->{value};
+         my $version = $rows->{$var}->{value};
-      PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version);
+         PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version);
-      push @versions, $version;
+         push @versions, $version;
+      }
+
+      $version_for{$id} = join(' ', @versions);
    }
 
-   return join(' ', @versions);
+   return \%version_for;
 }
 
 sub get_bin_version {

t/lib/Pingback.t

@@ -15,10 +15,16 @@ use Pingback;
 use PerconaTest;
 use DSNParser;
 use Sandbox;
+
+use Digest::MD5 qw(md5_hex);
+use Sys::Hostname  qw(hostname);
+
 my $dp  = DSNParser->new(opts=>$dsn_opts);
 my $sb  = Sandbox->new(basedir => '/tmp', DSNParser => $dp);
 my $dbh = $sb->get_dbh_for('master');
 
+my $general_id = md5_hex( hostname() );
+
 # #############################################################################
 # Fake User Agent package, so we can simulate server responses
 # and fake accepting client responses.
@@ -62,9 +68,9 @@ sub test_pingback {
    my $sug;
    eval {
       $sug = Pingback::pingback(
-         url => $url,
+         url       => $url,
-         dbh => $args{dbh},
+         instances => $args{instances},
-         ua  => $fake_ua,
+         ua        => $fake_ua,
       );
    };
    if ( $args{no_response} ) {
@@ -84,7 +90,7 @@ sub test_pingback {
 
    is(
       $post ? ($post->{content} || '') : '',
-      $args{post},
+      join("", map { "$general_id;$_\n" } split /\n/, $args{post}),
       "$args{name} client response"
    );
 
@@ -169,10 +175,10 @@ SKIP: {
       = $dbh->selectrow_array("SHOW VARIABLES LIKE 'version'");
    my (undef, $mysql_distro)
       = $dbh->selectrow_array("SHOW VARIABLES LIKE 'version_comment'");
-
+      
    test_pingback(
       name => "MySQL version",
-      dbh  => $dbh,
+      instances => { $general_id => $dbh },
       response => [
          # in response to client's GET
          { status  => 200,
@@ -200,12 +206,12 @@ my $file  = File::Spec->catfile($dir, 'percona-toolkit-version-check-test');
 unlink $file;
 
 ok(
-   Pingback::time_to_check($file),
+   Pingback::time_to_check($file, []),
    "time_to_check() returns true if the file doesn't exist",
 );
 
 ok(
-   !Pingback::time_to_check($file),
+   !Pingback::time_to_check($file, []),
    "...but false if it exists and it's been less than 24 hours",
 );
 
@@ -222,16 +228,76 @@ cmp_ok(
 );
 
 ok(
-   Pingback::time_to_check($file),
+   Pingback::time_to_check($file, []),
-   "time_to_check true if file exists and mtime < one day",
+   "time_to_check true if file exists and mtime < one day", #>"
 );
 
 ok(
-   !Pingback::time_to_check($file),
+   !Pingback::time_to_check($file, []),
    "...but fails if tried a second time, as the mtime has been updated",
 );
 
-unlink $file;
+# #############################################################################
+# _generate_identifier
+# #############################################################################
+
+is(
+   Pingback::_generate_identifier( { dbh => undef, dsn => { h => "localhost", P => 12345 } } ),
+   md5_hex("localhost", 12345),
+   "_generate_identifier() works as expected for 4.1",
+);
+
+SKIP: {
+   skip 'Cannot connect to sandbox master', 2 unless $dbh;
+   skip 'These tests are for MySQL 5.0.38 onwards', unless $sandbox_version ge '5.0.38';
+
+   my $sql  = q{SELECT MD5(CONCAT(@@hostname, @@port))};
+   my ($id) = eval { $dbh->selectrow_array($sql) };
+
+   is(
+      Pingback::_generate_identifier( { dbh => $dbh, dsn => undef } ),
+      $id,
+      "_generate_identifier() works with a dbh"
+   );
+
+   
+   is_deeply(
+      Pingback::time_to_check($file, [ $id ]),
+      [ $id ],
+      "But even in an old file, it'll return true, and an arrayref, if we pass a new id",
+   );
+
+   ok(
+      !Pingback::time_to_check($file, [ $id ]),
+      "...but not the second time around",
+   );
+
+   open my $fh, q{>}, $file or die $!;
+   print { $fh } "$id," . (time() - $one_day * 2) . "\n";
+   close $fh;
+
+   is_deeply(
+      Pingback::time_to_check($file, [ $id ]),
+      [ $id ],
+      "...unless more than a day has gone past",
+   );
+
+   my $slave_dbh = $sb->get_dbh_for('slave1');
+   my ($id2)     = Pingback::_generate_identifier( { dbh => $slave_dbh, dsn => undef } );
+   is_deeply(
+      Pingback::time_to_check($file, [ $id, $id2 ]),
+      [ $id2 ],
+      "With multiple ids, time_to_check() returns only those that need checking",
+   );
+
+   my $check = Pingback::time_to_check($file, [ $id, $id2 ]);
+   ok(
+      !$check,
+      "...and false if there isn't anything to check",
+   ) or diag(Dumper($check));
+}
+
+1 while unlink $file;
 
 # #############################################################################
 # Done.

t/lib/VersionCheck.t

@@ -20,6 +20,7 @@ use PerconaTest;
 my $dp  = new DSNParser(opts=>$dsn_opts);
 my $sb  = new Sandbox(basedir => '/tmp', DSNParser => $dp);
 my $dbh = $sb->get_dbh_for('master');
+my $slave_dbh = $sb->get_dbh_for('slave1');
 
 my $vc = VersionCheck->new();
 
@@ -36,8 +37,8 @@ sub test_v {
    );
 
    my $versions = $vc->get_versions(
-      items => $items,
+      items     => $items,
-      dbh   => $dbh,
+      instances => { "0xDEADBEEF" => $dbh, "0x8BADF00D" => $slave_dbh },
    );
    diag(Dumper($versions));
    is_deeply(
@@ -142,7 +143,10 @@ SKIP: {
          },
       },
       versions => {
-         'MySQL' => "$mysql_distro $mysql_version",
+         'MySQL' => {
+            "0xDEADBEEF" => "$mysql_distro $mysql_version",
+            "0x8BADF00D" => "$mysql_distro $mysql_version"
+         },
       },
    );
 }