Make Pingback::pingback() do all the work, return list of advices (suggestions). More Pingback tests. Rename --check-for-updates to --version-check and document. Make VersionCheck::parse_server_response() optionally not split vars, so the same proto can be used for server advice lines.

bin/pt-table-checksum

@@ -49,15 +49,15 @@ sub parse_server_response {
    }
    my ($response) = @args{@required_args};
 
-   PTDEBUG && _d('Server response:', $response); 
-
    my %items = map {
       my ($item, $type, $vars) = split(";", $_);
-      my (@vars)               = split(",", ($vars || ''));
+      if ( !defined $args{split_vars} || $args{split_vars} ) {
+         $vars = [ split(",", ($vars || '')) ];
+      }
       $item => {
          item => $item,
          type => $type,
-         vars => \@vars,
+         vars => $vars,
       };
    } split("\n", $response);
 
@@ -235,9 +235,11 @@ sub get_bin_version {
    return unless $cmd;
 
    my $sanitized_command = File::Basename::basename($cmd);
+   PTDEBUG && _d('cmd:', $cmd, 'sanitized:', $sanitized_command);
    return if $sanitized_command !~ /\A[a-zA-Z0-9_-]+\z/;
 
    my $output = `$sanitized_command --version 2>&1`;
+   PTDEBUG && _d('output:', $output);
 
    my ($version) = $output =~ /v?([0-9]+\.[0-9]+(?:\.[\w-]+)?)/;
 
@@ -737,20 +739,6 @@ eval {
    require VersionCheck;
 };
 
-sub ping_for_updates {
-   my (%args) = @_;
-   my $advice = "";
-   my $response = pingback(%args);
-
-   PTDEBUG && _d('Server response:', Dumper($response));
-   if ( $response && $response->{success} ) {
-      $advice = $response->{content};
-      $advice =~ s/\r\n/\n/g; # Normalize linefeeds
-   }
-
-   return $advice;
-}
-
 sub pingback {
    my (%args) = @_;
    my @required_args = qw(url);
@@ -766,7 +754,7 @@ sub pingback {
 
    my $response = $ua->request('GET', $url);
    PTDEBUG && _d('Server response:', Dumper($response));
-   return unless $response->{status} == 200;
+   return unless $response && $response->{status} == 200 && $response->{content};
 
    my $items = $vc->parse_server_response(
       response => $response->{content}
@@ -788,10 +776,22 @@ sub pingback {
       headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
       content => $client_content,
    };
+   PTDEBUG && _d('Client response:', Dumper($client_response));
 
-   PTDEBUG && _d('Sending back to the server:', Dumper($response));
+   $response = $ua->request('POST', $url, $client_response);
+   PTDEBUG && _d('Server suggestions:', Dumper($response));
+   return unless $response && $response->{status} == 200 && $response->{content};
 
-   return $ua->request('POST', $url, $client_response);
+   $items = $vc->parse_server_response(
+      response   => $response->{content},
+      split_vars => 0,
+   );
+   return unless scalar keys %$items;
+   my @suggestions = map { $_->{vars} }
+                     sort { $a->{item} cmp $b->{item} }
+                     values %$items;
+
+   return \@suggestions;
 }
 
 sub encode_client_response {
@@ -7869,11 +7869,25 @@ sub main {
    # Check for updates
    # ########################################################################
 
-   if ( $o->get('check-for-updates') ) {
+   if ( $o->get('version-check') ) {
-      print Pingback::ping_for_updates(
+      # 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.
+      eval {
+         my $advice = Pingback::pingback(
             url => 'http://staging.upgrade.percona.com',
             dbh => $master_dbh
          );
+         if ( $advice ) {
+            # TODO: print this at the start or the end?
+            # TODO: how to format this?
+            print "--version-check advice:\n";
+            print join("\n", map { "  * $_" } @$advice);
+         }
+      };
+      if ( $EVAL_ERROR ) {
+         PTDEBUG && _d('Error doing --version-check:', $EVAL_ERROR);
+      }
    }
    
    # ########################################################################
@@ -9959,12 +9973,6 @@ checksum times will vary, but query checksum sizes will not. Another way to do
 the same thing is to specify a value for L<"--chunk-size"> explicitly, instead
 of leaving it at the default.
 
-=item --[no]check-for-updates
-
-default: yes
-
-XXX TODO DOCS
-
 =item --columns
 
 short form: -c; type: array; group: Filter
@@ -9978,6 +9986,8 @@ type: Array; group: Config
 Read this comma-separated list of config files; if specified, this must be the
 first option on the command line.
 
+See the L<"--help"> output for a list of default config files.
+
 =item --[no]create-replicate-table
 
 default: yes
@@ -10407,6 +10417,24 @@ group: Help
 
 Show version and exit.
 
+=item --[no]version-check
+
+default: yes
+
+Send program versions to Percona and print suggested upgrades and problems.
+
+The version check feature causes the tool to send and receive data from
+Percona over the web.  The data contains program versions from the local
+machine.  Percona uses the data to focus development on the most widely
+used versions of programs, and to suggest to customers possible upgrades
+and known bad versions of programs.
+
+This feature can be disabled by specifying C<--no-version-check> on the
+command line or in one of several L<"--config"> files, or by setting the
+environment variable C<PERCONA_VERSION_CHECK=0>.
+
+For more information, visit L<http://www.percona.com/version-check>.
+
 =item --where
 
 type: string

lib/Pingback.pm

@@ -45,20 +45,6 @@ eval {
    require VersionCheck;
 };
 
-sub ping_for_updates {
-   my (%args) = @_;
-   my $advice = "";
-   my $response = pingback(%args);
-
-   PTDEBUG && _d('Server response:', Dumper($response));
-   if ( $response && $response->{success} ) {
-      $advice = $response->{content};
-      $advice =~ s/\r\n/\n/g; # Normalize linefeeds
-   }
-
-   return $advice;
-}
-
 sub pingback {
    my (%args) = @_;
    my @required_args = qw(url);
@@ -82,7 +68,7 @@ sub pingback {
    # items/types that need extra hints.
    my $response = $ua->request('GET', $url);
    PTDEBUG && _d('Server response:', Dumper($response));
-   return unless $response->{status} == 200;
+   return unless $response && $response->{status} == 200 && $response->{content};
 
    # Parse the plaintext server response into a hashref keyed on
    # the items like:
@@ -117,10 +103,25 @@ sub pingback {
       headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
       content => $client_content,
    };
+   PTDEBUG && _d('Client response:', Dumper($client_response));
 
-   PTDEBUG && _d('Sending back to the server:', Dumper($response));
+   $response = $ua->request('POST', $url, $client_response);
+   PTDEBUG && _d('Server suggestions:', Dumper($response));
+   return unless $response && $response->{status} == 200 && $response->{content};
 
-   return $ua->request('POST', $url, $client_response);
+   # 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 = $vc->parse_server_response(
+      response   => $response->{content},
+      split_vars => 0,
+   );
+   return unless scalar keys %$items;
+   my @suggestions = map { $_->{vars} }
+                     sort { $a->{item} cmp $b->{item} }
+                     values %$items;
+
+   return \@suggestions;
 }
 
 sub encode_client_response {

lib/VersionCheck.pm

@@ -52,15 +52,15 @@ sub parse_server_response {
    }
    my ($response) = @args{@required_args};
 
-   PTDEBUG && _d('Server response:', $response); 
-
    my %items = map {
       my ($item, $type, $vars) = split(";", $_);
-      my (@vars)               = split(",", ($vars || ''));
+      if ( !defined $args{split_vars} || $args{split_vars} ) {
+         $vars = [ split(",", ($vars || '')) ];
+      }
       $item => {
          item => $item,
          type => $type,
-         vars => \@vars,
+         vars => $vars,
       };
    } split("\n", $response);
 
@@ -252,9 +252,11 @@ sub get_bin_version {
    return unless $cmd;
 
    my $sanitized_command = File::Basename::basename($cmd);
+   PTDEBUG && _d('cmd:', $cmd, 'sanitized:', $sanitized_command);
    return if $sanitized_command !~ /\A[a-zA-Z0-9_-]+\z/;
 
    my $output = `$sanitized_command --version 2>&1`;
+   PTDEBUG && _d('output:', $output);
 
    my ($version) = $output =~ /v?([0-9]+\.[0-9]+(?:\.[\w-]+)?)/;
 

t/lib/Pingback.t

@@ -24,17 +24,22 @@ my $dbh = $sb->get_dbh_for('master');
 # and fake accepting client responses.
 # #############################################################################
 
-my $get;   # server reponses
+my $response;  # responses to client
-my $post;  # client responses
+my $post;      # what client sends for POST
 {
    package FakeUA;
 
    sub new { bless {}, $_[0] }
    sub request {
       my ($self, $type, $url, $content) = @_;
-      return shift @$get if $type eq 'GET';
+      if ( $type eq 'GET' ) {
-      $post = $content   if $type eq 'POST';
+         return shift @$response;
-      return;
+      }
+      elsif ( $type eq 'POST' ) {
+         $post = $content;
+         return shift @$response;
+      }
+      die "Invalid client request method: $type";
    }
 }
 
@@ -51,11 +56,12 @@ my $dd_ver   = $Data::Dumper::VERSION;
 sub test_pingback {
    my (%args) = @_;
 
-   $get  = $args{get};
+   $response = $args{response};
    $post = "";  # clear previous test
 
+   my $sug;
    eval {
-      Pingback::pingback(
+      $sug = Pingback::pingback(
          url => $url,
          dbh => $args{dbh},
          ua  => $fake_ua,
@@ -68,22 +74,78 @@ sub test_pingback {
    );
 
    is(
-      $post->{content},
+      $post ? ($post->{content} || '') : '',
       $args{post},
       "$args{name} client response"
-   )
+   );
+
+   is_deeply(
+      $sug,
+      $args{sug},
+      "$args{name} suggestions"
+   );
 }
 
 test_pingback(
-   name => "Perl version and Data::Dumper::VERSION",
+   name => "Perl version and module version",
-   # Client gets this from the server:
+   response => [
-   get  => [
+      # in response to client's GET
+      { status  => 200,
+        content => "Perl;perl_version;PERL_VERSION\nData::Dumper;perl_module_version\n",
+      },
+      # in response to client's POST
+      { status  => 200,
+        content => "Perl;perl_version;Perl 5.8 is wonderful.\nData::Dumper;perl_module_version;Data::Printer is nicer.\n",
+      }
+   ],
+   # client should POST this
+   post => "Data::Dumper;perl_module_version;$dd_ver\nPerl;perl_version;$perl_ver\n",
+   # Server should return these suggetions after the client posts
+   sug  => [
+      'Data::Printer is nicer.',
+      'Perl 5.8 is wonderful.',
+   ],
+);
+
+# Client should handle not getting any suggestions.
+
+test_pingback(
+   name => "Versions but no suggestions",
+   response => [
+      # in response to client's GET
+      { status  => 200,
+        content => "Perl;perl_version;PERL_VERSION\nData::Dumper;perl_module_version\n",
+      },
+      # in response to client's POST
+      { status  => 200,
+        content => "",
+      }
+   ],
+   post => "Data::Dumper;perl_module_version;$dd_ver\nPerl;perl_version;$perl_ver\n",
+   sug  => undef,
+);
+
+# Client should handle no response to GET.
+
+test_pingback(
+   name => "No response to GET",
+   response => [],
+   post => "",
+   sug  => undef,
+);
+
+# Client should handle no response to POST.
+
+test_pingback(
+   name => "No response to POST",
+   response => [
+      # in response to client's GET
       { status  => 200,
         content => "Perl;perl_version;PERL_VERSION\nData::Dumper;perl_module_version\n",
       },
    ],
-   # And it responds with this:
    post => "Data::Dumper;perl_module_version;$dd_ver\nPerl;perl_version;$perl_ver\n",
+   sug  => undef,
 );
 
 # #############################################################################
@@ -99,13 +161,21 @@ SKIP: {
 
    test_pingback(
       name => "MySQL version",
-      get  => [
+      dbh  => $dbh,
+      response => [
+         # in response to client's GET
          { status  => 200,
            content => "MySQL;mysql_variable;version,version_comment\n",
          },
+         # in response to client's POST
+         { status  => 200,
+           content => "MySQL;mysql_variable;Percona Server is fast.\n",
+         }
       ],
+      # client should POST this
       post => "MySQL;mysql_variable;$mysql_ver $mysql_distro\n",
-      dbh  => $dbh,
+      # Server should return these suggetions after the client posts
+      sug => ['Percona Server is fast.'],
    );
 }
 

t/lib/VersionCheck.t

@@ -61,12 +61,12 @@ sub test_v {
 
 test_v(
    name     => "Perl version",
-   response => "Perl;perl_version;PERL_VERSION\n",
+   response => "Perl;perl_version\n",
    items    => {
       'Perl' => {
          item => 'Perl',
          type => 'perl_version',
-         vars => [qw(PERL_VERSION)],
+         vars => [],
       },
    },
    versions => {