mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-11 21:51:21 +00:00
Add a prototype implementation of the pingback feature to ptc
This commit is contained in:
Brian Fraser
@@ -8,6 +8,825 @@ use strict;
|
|||||||
use warnings FATAL => 'all';
|
use warnings FATAL => 'all';
|
||||||
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
||||||
|
|
||||||
|
# ###########################################################################
|
||||||
|
# VersionCheck package
|
||||||
|
# This package is a copy without comments from the original. The original
|
||||||
|
# with comments and its test file can be found in the Bazaar repository at,
|
||||||
|
# lib/VersionCheck.pm
|
||||||
|
# t/lib/VersionCheck.t
|
||||||
|
# See https://launchpad.net/percona-toolkit for more information.
|
||||||
|
# ###########################################################################
|
||||||
|
{
|
||||||
|
package VersionCheck;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings FATAL => 'all';
|
||||||
|
use English qw(-no_match_vars);
|
||||||
|
|
||||||
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
||||||
|
|
||||||
|
use File::Basename ();
|
||||||
|
use Data::Dumper ();
|
||||||
|
|
||||||
|
sub Dumper {
|
||||||
|
local $Data::Dumper::Indent = 1;
|
||||||
|
local $Data::Dumper::Sortkeys = 1;
|
||||||
|
local $Data::Dumper::Quotekeys = 0;
|
||||||
|
|
||||||
|
Data::Dumper::Dumper(@_);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my ($class, %args) = @_;
|
||||||
|
return bless {}, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub parse_server_response {
|
||||||
|
my ($self, %args) = @_;
|
||||||
|
my @required_args = qw(response);
|
||||||
|
foreach my $arg ( @required_args ) {
|
||||||
|
die "I need a $arg arugment" unless $args{$arg};
|
||||||
|
}
|
||||||
|
my ($response) = @args{@required_args};
|
||||||
|
|
||||||
|
PTDEBUG && _d('Server response:', $response);
|
||||||
|
|
||||||
|
my %items = map {
|
||||||
|
my ($item, $type, $vars) = split(";", $_);
|
||||||
|
my (@vars) = split(",", ($vars || ''));
|
||||||
|
$item => {
|
||||||
|
item => $item,
|
||||||
|
type => $type,
|
||||||
|
vars => \@vars,
|
||||||
|
};
|
||||||
|
} split("\n", $response);
|
||||||
|
|
||||||
|
PTDEBUG && _d('Items:', Dumper(\%items));
|
||||||
|
|
||||||
|
return \%items;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_versions {
|
||||||
|
my ($self, %args) = @_;
|
||||||
|
my @required_args = qw(items);
|
||||||
|
foreach my $arg ( @required_args ) {
|
||||||
|
die "I need a $arg arugment" unless $args{$arg};
|
||||||
|
}
|
||||||
|
my ($items) = @args{@required_args};
|
||||||
|
my $dbh = $args{dbh}; # optional
|
||||||
|
|
||||||
|
my %versions;
|
||||||
|
foreach my $item ( values %$items ) {
|
||||||
|
next unless $self->valid_item($item);
|
||||||
|
|
||||||
|
eval {
|
||||||
|
my $func = 'get_' . $item->{type};
|
||||||
|
my $version = $self->$func(
|
||||||
|
item => $item,
|
||||||
|
dbh => $dbh,
|
||||||
|
);
|
||||||
|
if ( $version ) {
|
||||||
|
chomp $version;
|
||||||
|
$versions{$item->{item}} = $version;
|
||||||
|
}
|
||||||
|
};
|
||||||
|
if ( $EVAL_ERROR ) {
|
||||||
|
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return \%versions;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub valid_item {
|
||||||
|
my ($self, $item) = @_;
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_os_version {
|
||||||
|
my ($self) = @_;
|
||||||
|
|
||||||
|
chomp(my $platform = `uname -s`);
|
||||||
|
PTDEBUG && _d('platform:', $platform);
|
||||||
|
return $OSNAME unless $platform;
|
||||||
|
|
||||||
|
chomp(my $lsb_release
|
||||||
|
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
|
||||||
|
PTDEBUG && _d('lsb_release:', $lsb_release);
|
||||||
|
|
||||||
|
my $release = "";
|
||||||
|
|
||||||
|
if ( $platform eq 'Linux' ) {
|
||||||
|
if ( -f "/etc/fedora-release" ) {
|
||||||
|
$release = `cat /etc/fedora-release`;
|
||||||
|
}
|
||||||
|
elsif ( -f "/etc/redhat-release" ) {
|
||||||
|
$release = `cat /etc/redhat-release`;
|
||||||
|
}
|
||||||
|
elsif ( -f "/etc/system-release" ) {
|
||||||
|
$release = `cat /etc/system-release`;
|
||||||
|
}
|
||||||
|
elsif ( $lsb_release ) {
|
||||||
|
$release = `$lsb_release -ds`;
|
||||||
|
}
|
||||||
|
elsif ( -f "/etc/lsb-release" ) {
|
||||||
|
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
|
||||||
|
$release =~ s/^\w+="([^"]+)".+/$1/;
|
||||||
|
}
|
||||||
|
elsif ( -f "/etc/debian_version" ) {
|
||||||
|
chomp(my $rel = `cat /etc/debian_version`);
|
||||||
|
$release = "Debian $rel";
|
||||||
|
if ( -f "/etc/apt/sources.list" ) {
|
||||||
|
chomp(my $code_name = `awk '/^deb/ {print \$3}' /etc/apt/sources.list | awk -F/ '{print \$1}'| awk 'BEGIN {FS="|"} {print \$1}' | sort | uniq -c | sort -rn | head -n1 | awk '{print \$2}'`);
|
||||||
|
$release .= " ($code_name)" if $code_name;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
elsif ( `ls /etc/*release 2>/dev/null` ) {
|
||||||
|
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
|
||||||
|
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$release = `cat /etc/*release | head -n1`;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
elsif ( $platform =~ m/^(BSD|Darwin)$/ ) {
|
||||||
|
my $rel = `uname -r`;
|
||||||
|
$release = "$platform $rel";
|
||||||
|
}
|
||||||
|
elsif ( $platform eq "SunOS" ) {
|
||||||
|
my $rel = `head -n1 /etc/release` || `uname -r`;
|
||||||
|
$release = "$platform $rel";
|
||||||
|
}
|
||||||
|
|
||||||
|
if ( !$release ) {
|
||||||
|
PTDEBUG && _d('Failed to get the release, using platform');
|
||||||
|
$release = $platform;
|
||||||
|
}
|
||||||
|
chomp($release);
|
||||||
|
|
||||||
|
PTDEBUG && _d('OS version =', $release);
|
||||||
|
return $release;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_perl_version {
|
||||||
|
my ($self, %args) = @_;
|
||||||
|
my $item = $args{item};
|
||||||
|
return unless $item;
|
||||||
|
|
||||||
|
my $version = sprintf '%vd', $PERL_VERSION;
|
||||||
|
PTDEBUG && _d('Perl version', $version);
|
||||||
|
return $version;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_perl_module_version {
|
||||||
|
my ($self, %args) = @_;
|
||||||
|
my $item = $args{item};
|
||||||
|
return unless $item;
|
||||||
|
|
||||||
|
my $var = $item->{item} . '::VERSION';
|
||||||
|
my $version = _get_scalar($var);
|
||||||
|
PTDEBUG && _d('Perl version for', $var, '=', "$version");
|
||||||
|
|
||||||
|
return $version ? "$version" : $version;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _get_scalar {
|
||||||
|
no strict;
|
||||||
|
return ${*{shift()}};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_mysql_variable {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->_get_from_mysql(
|
||||||
|
show => 'VARIABLES',
|
||||||
|
@_,
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub _get_from_mysql {
|
||||||
|
my ($self, %args) = @_;
|
||||||
|
my $show = $args{show};
|
||||||
|
my $item = $args{item};
|
||||||
|
my $dbh = $args{dbh};
|
||||||
|
return unless $show && $item && $dbh;
|
||||||
|
|
||||||
|
local $dbh->{FetchHashKeyName} = 'NAME_lc';
|
||||||
|
my $sql = qq/SHOW $show/;
|
||||||
|
PTDEBUG && _d($sql);
|
||||||
|
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
|
||||||
|
|
||||||
|
my @versions;
|
||||||
|
foreach my $var ( @{$item->{vars}} ) {
|
||||||
|
$var = lc($var);
|
||||||
|
my $version = $rows->{$var}->{value};
|
||||||
|
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version);
|
||||||
|
push @versions, $version;
|
||||||
|
}
|
||||||
|
|
||||||
|
return join(' ', @versions);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_bin_version {
|
||||||
|
my ($self, %args) = @_;
|
||||||
|
my $item = $args{item};
|
||||||
|
my $cmd = $item->{item};
|
||||||
|
return unless $cmd;
|
||||||
|
|
||||||
|
my $sanitized_command = File::Basename::basename($cmd);
|
||||||
|
return if $sanitized_command !~ /\A[a-zA-Z0-9_-]+\z/;
|
||||||
|
|
||||||
|
my $output = `$sanitized_command --version 2>&1`;
|
||||||
|
|
||||||
|
my ($version) = $output =~ /v?([0-9]+\.[0-9]+(?:\.[\w-]+)?)/;
|
||||||
|
|
||||||
|
PTDEBUG && _d('Version for', $sanitized_command, '=', $version);
|
||||||
|
return $version;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _d {
|
||||||
|
my ($package, undef, $line) = caller 0;
|
||||||
|
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
|
||||||
|
map { defined $_ ? $_ : 'undef' }
|
||||||
|
@_;
|
||||||
|
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
}
|
||||||
|
# ###########################################################################
|
||||||
|
# End VersionCheck package
|
||||||
|
# ###########################################################################
|
||||||
|
|
||||||
|
# ###########################################################################
|
||||||
|
# HTTPMicro package
|
||||||
|
# This package is a copy without comments from the original. The original
|
||||||
|
# with comments and its test file can be found in the Bazaar repository at,
|
||||||
|
# lib/HTTPMicro.pm
|
||||||
|
# t/lib/HTTPMicro.t
|
||||||
|
# See https://launchpad.net/percona-toolkit for more information.
|
||||||
|
# ###########################################################################
|
||||||
|
{
|
||||||
|
|
||||||
|
package HTTP::Micro;
|
||||||
|
BEGIN {
|
||||||
|
$HTTP::Micro::VERSION = '0.001';
|
||||||
|
}
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
use Carp ();
|
||||||
|
|
||||||
|
|
||||||
|
my @attributes;
|
||||||
|
BEGIN {
|
||||||
|
@attributes = qw(agent timeout);
|
||||||
|
no strict 'refs';
|
||||||
|
for my $accessor ( @attributes ) {
|
||||||
|
*{$accessor} = sub {
|
||||||
|
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
|
||||||
|
};
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my($class, %args) = @_;
|
||||||
|
(my $agent = $class) =~ s{::}{-}g;
|
||||||
|
my $self = {
|
||||||
|
agent => $agent . "/" . ($class->VERSION || 0),
|
||||||
|
timeout => 60,
|
||||||
|
};
|
||||||
|
for my $key ( @attributes ) {
|
||||||
|
$self->{$key} = $args{$key} if exists $args{$key}
|
||||||
|
}
|
||||||
|
return bless $self, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub request {
|
||||||
|
my ($self, $method, $url, $args) = @_;
|
||||||
|
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
|
||||||
|
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
|
||||||
|
$args ||= {}; # we keep some state in this during _request
|
||||||
|
|
||||||
|
my $response;
|
||||||
|
for ( 0 .. 1 ) {
|
||||||
|
$response = eval { $self->_request($method, $url, $args) };
|
||||||
|
last unless $@ && $method eq 'GET'
|
||||||
|
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
|
||||||
|
}
|
||||||
|
|
||||||
|
if (my $e = "$@") {
|
||||||
|
$response = {
|
||||||
|
success => q{},
|
||||||
|
status => 599,
|
||||||
|
reason => 'Internal Exception',
|
||||||
|
content => $e,
|
||||||
|
headers => {
|
||||||
|
'content-type' => 'text/plain',
|
||||||
|
'content-length' => length $e,
|
||||||
|
}
|
||||||
|
};
|
||||||
|
}
|
||||||
|
return $response;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _request {
|
||||||
|
my ($self, $method, $url, $args) = @_;
|
||||||
|
|
||||||
|
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
|
||||||
|
|
||||||
|
my $request = {
|
||||||
|
method => $method,
|
||||||
|
scheme => $scheme,
|
||||||
|
host_port => ($port == 80 ? $host : "$host:$port"),
|
||||||
|
uri => $path_query,
|
||||||
|
headers => {},
|
||||||
|
};
|
||||||
|
|
||||||
|
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
|
||||||
|
|
||||||
|
$handle->connect($scheme, $host, $port);
|
||||||
|
|
||||||
|
$self->_prepare_headers_and_cb($request, $args);
|
||||||
|
$handle->write_request_header(@{$request}{qw/method uri headers/});
|
||||||
|
$handle->write_content_body($request) if $request->{content};
|
||||||
|
|
||||||
|
my $response;
|
||||||
|
do { $response = $handle->read_response_header }
|
||||||
|
until (substr($response->{status},0,1) ne '1');
|
||||||
|
|
||||||
|
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
|
||||||
|
$response->{content} = '';
|
||||||
|
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
|
||||||
|
}
|
||||||
|
|
||||||
|
$handle->close;
|
||||||
|
$response->{success} = substr($response->{status},0,1) eq '2';
|
||||||
|
return $response;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _prepare_headers_and_cb {
|
||||||
|
my ($self, $request, $args) = @_;
|
||||||
|
|
||||||
|
for ($args->{headers}) {
|
||||||
|
next unless defined;
|
||||||
|
while (my ($k, $v) = each %$_) {
|
||||||
|
$request->{headers}{lc $k} = $v;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
$request->{headers}{'host'} = $request->{host_port};
|
||||||
|
$request->{headers}{'connection'} = "close";
|
||||||
|
$request->{headers}{'user-agent'} ||= $self->{agent};
|
||||||
|
|
||||||
|
if (defined $args->{content}) {
|
||||||
|
$request->{headers}{'content-type'} ||= "application/octet-stream";
|
||||||
|
utf8::downgrade($args->{content}, 1)
|
||||||
|
or Carp::croak(q/Wide character in request message body/);
|
||||||
|
$request->{headers}{'content-length'} = length $args->{content};
|
||||||
|
}
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _split_url {
|
||||||
|
my $url = pop;
|
||||||
|
|
||||||
|
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
|
||||||
|
or Carp::croak(qq/Cannot parse URL: '$url'/);
|
||||||
|
|
||||||
|
$scheme = lc $scheme;
|
||||||
|
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
|
||||||
|
|
||||||
|
my $host = (length($authority)) ? lc $authority : 'localhost';
|
||||||
|
$host =~ s/\A[^@]*@//; # userinfo
|
||||||
|
my $port = do {
|
||||||
|
$host =~ s/:([0-9]*)\z// && length $1
|
||||||
|
? $1
|
||||||
|
: ($scheme eq 'http' ? 80 : undef);
|
||||||
|
};
|
||||||
|
|
||||||
|
return ($scheme, $host, $port, $path_query);
|
||||||
|
}
|
||||||
|
|
||||||
|
package
|
||||||
|
HTTP::Micro::Handle; # hide from PAUSE/indexers
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
use Carp qw[croak];
|
||||||
|
use Errno qw[EINTR EPIPE];
|
||||||
|
use IO::Socket qw[SOCK_STREAM];
|
||||||
|
|
||||||
|
sub BUFSIZE () { 32768 }
|
||||||
|
|
||||||
|
my $Printable = sub {
|
||||||
|
local $_ = shift;
|
||||||
|
s/\r/\\r/g;
|
||||||
|
s/\n/\\n/g;
|
||||||
|
s/\t/\\t/g;
|
||||||
|
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
|
||||||
|
$_;
|
||||||
|
};
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my ($class, %args) = @_;
|
||||||
|
return bless {
|
||||||
|
rbuf => '',
|
||||||
|
timeout => 60,
|
||||||
|
max_line_size => 16384,
|
||||||
|
%args
|
||||||
|
}, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub connect {
|
||||||
|
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
|
||||||
|
my ($self, $scheme, $host, $port) = @_;
|
||||||
|
|
||||||
|
if ( $scheme ne 'http' ) {
|
||||||
|
croak(qq/Unsupported URL scheme '$scheme'/);
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->{fh} = 'IO::Socket::INET'->new(
|
||||||
|
PeerHost => $host,
|
||||||
|
PeerPort => $port,
|
||||||
|
Proto => 'tcp',
|
||||||
|
Type => SOCK_STREAM,
|
||||||
|
Timeout => $self->{timeout}
|
||||||
|
) or croak(qq/Could not connect to '$host:$port': $@/);
|
||||||
|
|
||||||
|
binmode($self->{fh})
|
||||||
|
or croak(qq/Could not binmode() socket: '$!'/);
|
||||||
|
|
||||||
|
$self->{host} = $host;
|
||||||
|
$self->{port} = $port;
|
||||||
|
|
||||||
|
return $self;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub close {
|
||||||
|
@_ == 1 || croak(q/Usage: $handle->close()/);
|
||||||
|
my ($self) = @_;
|
||||||
|
CORE::close($self->{fh})
|
||||||
|
or croak(qq/Could not close socket: '$!'/);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub write {
|
||||||
|
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
|
||||||
|
my ($self, $buf) = @_;
|
||||||
|
|
||||||
|
my $len = length $buf;
|
||||||
|
my $off = 0;
|
||||||
|
|
||||||
|
local $SIG{PIPE} = 'IGNORE';
|
||||||
|
|
||||||
|
while () {
|
||||||
|
$self->can_write
|
||||||
|
or croak(q/Timed out while waiting for socket to become ready for writing/);
|
||||||
|
my $r = syswrite($self->{fh}, $buf, $len, $off);
|
||||||
|
if (defined $r) {
|
||||||
|
$len -= $r;
|
||||||
|
$off += $r;
|
||||||
|
last unless $len > 0;
|
||||||
|
}
|
||||||
|
elsif ($! == EPIPE) {
|
||||||
|
croak(qq/Socket closed by remote server: $!/);
|
||||||
|
}
|
||||||
|
elsif ($! != EINTR) {
|
||||||
|
croak(qq/Could not write to socket: '$!'/);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return $off;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub read {
|
||||||
|
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
|
||||||
|
my ($self, $len) = @_;
|
||||||
|
|
||||||
|
my $buf = '';
|
||||||
|
my $got = length $self->{rbuf};
|
||||||
|
|
||||||
|
if ($got) {
|
||||||
|
my $take = ($got < $len) ? $got : $len;
|
||||||
|
$buf = substr($self->{rbuf}, 0, $take, '');
|
||||||
|
$len -= $take;
|
||||||
|
}
|
||||||
|
|
||||||
|
while ($len > 0) {
|
||||||
|
$self->can_read
|
||||||
|
or croak(q/Timed out while waiting for socket to become ready for reading/);
|
||||||
|
my $r = sysread($self->{fh}, $buf, $len, length $buf);
|
||||||
|
if (defined $r) {
|
||||||
|
last unless $r;
|
||||||
|
$len -= $r;
|
||||||
|
}
|
||||||
|
elsif ($! != EINTR) {
|
||||||
|
croak(qq/Could not read from socket: '$!'/);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if ($len) {
|
||||||
|
croak(q/Unexpected end of stream/);
|
||||||
|
}
|
||||||
|
return $buf;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub readline {
|
||||||
|
@_ == 1 || croak(q/Usage: $handle->readline()/);
|
||||||
|
my ($self) = @_;
|
||||||
|
|
||||||
|
while () {
|
||||||
|
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
|
||||||
|
return $1;
|
||||||
|
}
|
||||||
|
$self->can_read
|
||||||
|
or croak(q/Timed out while waiting for socket to become ready for reading/);
|
||||||
|
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
|
||||||
|
if (defined $r) {
|
||||||
|
last unless $r;
|
||||||
|
}
|
||||||
|
elsif ($! != EINTR) {
|
||||||
|
croak(qq/Could not read from socket: '$!'/);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
croak(q/Unexpected end of stream while looking for line/);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub read_header_lines {
|
||||||
|
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
|
||||||
|
my ($self, $headers) = @_;
|
||||||
|
$headers ||= {};
|
||||||
|
my $lines = 0;
|
||||||
|
my $val;
|
||||||
|
|
||||||
|
while () {
|
||||||
|
my $line = $self->readline;
|
||||||
|
|
||||||
|
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
|
||||||
|
my ($field_name) = lc $1;
|
||||||
|
$val = \($headers->{$field_name} = $2);
|
||||||
|
}
|
||||||
|
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
|
||||||
|
$val
|
||||||
|
or croak(q/Unexpected header continuation line/);
|
||||||
|
next unless length $1;
|
||||||
|
$$val .= ' ' if length $$val;
|
||||||
|
$$val .= $1;
|
||||||
|
}
|
||||||
|
elsif ($line =~ /\A \x0D?\x0A \z/x) {
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
croak(q/Malformed header line: / . $Printable->($line));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return $headers;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub write_header_lines {
|
||||||
|
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
|
||||||
|
my($self, $headers) = @_;
|
||||||
|
|
||||||
|
my $buf = '';
|
||||||
|
while (my ($k, $v) = each %$headers) {
|
||||||
|
my $field_name = lc $k;
|
||||||
|
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
|
||||||
|
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
|
||||||
|
$field_name =~ s/\b(\w)/\u$1/g;
|
||||||
|
$buf .= "$field_name: $v\x0D\x0A";
|
||||||
|
}
|
||||||
|
$buf .= "\x0D\x0A";
|
||||||
|
return $self->write($buf);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub read_content_body {
|
||||||
|
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
|
||||||
|
my ($self, $cb, $response, $len) = @_;
|
||||||
|
$len ||= $response->{headers}{'content-length'};
|
||||||
|
|
||||||
|
croak("No content-length in the returned response, and this "
|
||||||
|
. "UA doesn't implement chunking") unless defined $len;
|
||||||
|
|
||||||
|
while ($len > 0) {
|
||||||
|
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
|
||||||
|
$cb->($self->read($read), $response);
|
||||||
|
$len -= $read;
|
||||||
|
}
|
||||||
|
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub write_content_body {
|
||||||
|
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
|
||||||
|
my ($self, $request) = @_;
|
||||||
|
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
|
||||||
|
|
||||||
|
$len += $self->write($request->{content});
|
||||||
|
|
||||||
|
$len == $content_length
|
||||||
|
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
|
||||||
|
|
||||||
|
return $len;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub read_response_header {
|
||||||
|
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
|
||||||
|
my ($self) = @_;
|
||||||
|
|
||||||
|
my $line = $self->readline;
|
||||||
|
|
||||||
|
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
|
||||||
|
or croak(q/Malformed Status-Line: / . $Printable->($line));
|
||||||
|
|
||||||
|
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
|
||||||
|
|
||||||
|
return {
|
||||||
|
status => $status,
|
||||||
|
reason => $reason,
|
||||||
|
headers => $self->read_header_lines,
|
||||||
|
protocol => $protocol,
|
||||||
|
};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub write_request_header {
|
||||||
|
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
|
||||||
|
my ($self, $method, $request_uri, $headers) = @_;
|
||||||
|
|
||||||
|
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
|
||||||
|
+ $self->write_header_lines($headers);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _do_timeout {
|
||||||
|
my ($self, $type, $timeout) = @_;
|
||||||
|
$timeout = $self->{timeout}
|
||||||
|
unless defined $timeout && $timeout >= 0;
|
||||||
|
|
||||||
|
my $fd = fileno $self->{fh};
|
||||||
|
defined $fd && $fd >= 0
|
||||||
|
or croak(q/select(2): 'Bad file descriptor'/);
|
||||||
|
|
||||||
|
my $initial = time;
|
||||||
|
my $pending = $timeout;
|
||||||
|
my $nfound;
|
||||||
|
|
||||||
|
vec(my $fdset = '', $fd, 1) = 1;
|
||||||
|
|
||||||
|
while () {
|
||||||
|
$nfound = ($type eq 'read')
|
||||||
|
? select($fdset, undef, undef, $pending)
|
||||||
|
: select(undef, $fdset, undef, $pending) ;
|
||||||
|
if ($nfound == -1) {
|
||||||
|
$! == EINTR
|
||||||
|
or croak(qq/select(2): '$!'/);
|
||||||
|
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
|
||||||
|
$nfound = 0;
|
||||||
|
}
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
$! = 0;
|
||||||
|
return $nfound;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub can_read {
|
||||||
|
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
|
||||||
|
my $self = shift;
|
||||||
|
return $self->_do_timeout('read', @_)
|
||||||
|
}
|
||||||
|
|
||||||
|
sub can_write {
|
||||||
|
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
|
||||||
|
my $self = shift;
|
||||||
|
return $self->_do_timeout('write', @_)
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
}
|
||||||
|
# ###########################################################################
|
||||||
|
# End HTTPMicro package
|
||||||
|
# ###########################################################################
|
||||||
|
|
||||||
|
# ###########################################################################
|
||||||
|
# Pingback package
|
||||||
|
# This package is a copy without comments from the original. The original
|
||||||
|
# with comments and its test file can be found in the Bazaar repository at,
|
||||||
|
# lib/Pingback.pm
|
||||||
|
# t/lib/Pingback.t
|
||||||
|
# See https://launchpad.net/percona-toolkit for more information.
|
||||||
|
# ###########################################################################
|
||||||
|
{
|
||||||
|
package Pingback;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use warnings FATAL => 'all';
|
||||||
|
use English qw(-no_match_vars);
|
||||||
|
|
||||||
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
||||||
|
|
||||||
|
use File::Basename ();
|
||||||
|
use Data::Dumper ();
|
||||||
|
|
||||||
|
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 HTTPMicro;
|
||||||
|
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);
|
||||||
|
foreach my $arg ( @required_args ) {
|
||||||
|
die "I need a $arg arugment" unless $args{$arg};
|
||||||
|
}
|
||||||
|
my ($url) = @args{@required_args};
|
||||||
|
|
||||||
|
my ($dbh, $ua, $vc) = @args{qw(dbh ua VersionCheck)};
|
||||||
|
|
||||||
|
$ua ||= HTTP::Micro->new();
|
||||||
|
$vc ||= VersionCheck->new();
|
||||||
|
|
||||||
|
my $response = $ua->request('GET', $url);
|
||||||
|
PTDEBUG && _d('Server response:', Dumper($response));
|
||||||
|
return unless $response->{status} == 200;
|
||||||
|
|
||||||
|
my $items = $vc->parse_server_response(
|
||||||
|
response => $response->{content}
|
||||||
|
);
|
||||||
|
return unless scalar keys %$items;
|
||||||
|
|
||||||
|
my $versions = $vc->get_versions(
|
||||||
|
items => $items,
|
||||||
|
dbh => $dbh,
|
||||||
|
);
|
||||||
|
return unless scalar keys %$versions;
|
||||||
|
|
||||||
|
my $client_content = encode_client_response(
|
||||||
|
items => $items,
|
||||||
|
versions => $versions,
|
||||||
|
);
|
||||||
|
|
||||||
|
my $client_response = {
|
||||||
|
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
|
||||||
|
content => $client_content,
|
||||||
|
};
|
||||||
|
|
||||||
|
PTDEBUG && _d('Sending back to the server:', Dumper($response));
|
||||||
|
|
||||||
|
return $ua->request('POST', $url, $client_response);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub encode_client_response {
|
||||||
|
my (%args) = @_;
|
||||||
|
my @required_args = qw(items versions);
|
||||||
|
foreach my $arg ( @required_args ) {
|
||||||
|
die "I need a $arg arugment" unless $args{$arg};
|
||||||
|
}
|
||||||
|
my ($items, $versions) = @args{@required_args};
|
||||||
|
|
||||||
|
my @lines;
|
||||||
|
foreach my $item ( sort keys %$items ) {
|
||||||
|
next unless exists $versions->{$item};
|
||||||
|
push @lines, join(';', $item,$items->{$item}->{type},$versions->{$item});
|
||||||
|
}
|
||||||
|
|
||||||
|
my $client_response = join("\n", @lines) . "\n";
|
||||||
|
PTDEBUG && _d('Client response:', $client_response);
|
||||||
|
return $client_response;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _d {
|
||||||
|
my ($package, undef, $line) = caller 0;
|
||||||
|
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
|
||||||
|
map { defined $_ ? $_ : 'undef' }
|
||||||
|
@_;
|
||||||
|
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
}
|
||||||
|
# ###########################################################################
|
||||||
|
# End Pingback package
|
||||||
|
# ###########################################################################
|
||||||
|
|
||||||
# ###########################################################################
|
# ###########################################################################
|
||||||
# DSNParser package
|
# DSNParser package
|
||||||
# This package is a copy without comments from the original. The original
|
# This package is a copy without comments from the original. The original
|
||||||
@@ -6827,7 +7646,7 @@ my %warn_code = (
|
|||||||
|
|
||||||
sub main {
|
sub main {
|
||||||
# Reset global vars else tests will fail in strange ways.
|
# Reset global vars else tests will fail in strange ways.
|
||||||
@ARGV = @_;
|
local @ARGV = @_;
|
||||||
$oktorun = 1;
|
$oktorun = 1;
|
||||||
$print_header = 1;
|
$print_header = 1;
|
||||||
|
|
||||||
@@ -6906,7 +7725,7 @@ sub main {
|
|||||||
}
|
}
|
||||||
|
|
||||||
$o->usage_or_errors();
|
$o->usage_or_errors();
|
||||||
|
|
||||||
# ########################################################################
|
# ########################################################################
|
||||||
# If --pid, check it first since we'll die if it already exists.
|
# If --pid, check it first since we'll die if it already exists.
|
||||||
# ########################################################################
|
# ########################################################################
|
||||||
@@ -7046,6 +7865,17 @@ sub main {
|
|||||||
my $master_dbh = $master_cxn->dbh(); # just for brevity
|
my $master_dbh = $master_cxn->dbh(); # just for brevity
|
||||||
my $master_dsn = $master_cxn->dsn(); # just for brevity
|
my $master_dsn = $master_cxn->dsn(); # just for brevity
|
||||||
|
|
||||||
|
# ########################################################################
|
||||||
|
# Check for updates
|
||||||
|
# ########################################################################
|
||||||
|
|
||||||
|
if ( $o->get('check-for-updates') ) {
|
||||||
|
print Pingback::ping_for_updates(
|
||||||
|
url => 'http://staging.upgrade.percona.com',
|
||||||
|
dbh => $master_dbh
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
# ########################################################################
|
# ########################################################################
|
||||||
# If this is not a dry run (--explain was not specified), then we're
|
# If this is not a dry run (--explain was not specified), then we're
|
||||||
# going to checksum the tables, so do the necessary preparations and
|
# going to checksum the tables, so do the necessary preparations and
|
||||||
@@ -9129,6 +9959,12 @@ 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
|
the same thing is to specify a value for L<"--chunk-size"> explicitly, instead
|
||||||
of leaving it at the default.
|
of leaving it at the default.
|
||||||
|
|
||||||
|
=item --[no]check-for-updates
|
||||||
|
|
||||||
|
default: yes
|
||||||
|
|
||||||
|
XXX TODO DOCS
|
||||||
|
|
||||||
=item --columns
|
=item --columns
|
||||||
|
|
||||||
short form: -c; type: array; group: Filter
|
short form: -c; type: array; group: Filter
|
||||||
|
|||||||
Reference in New Issue
Block a user