« back to all changes in this revision
Viewing changes to bin/pt-archiver
- browse files at revision 594
- compare with another revision
- download diff
- download tarball
- view history from revision 594
- Committer: Daniel Nichter
- Date: 2014-02-20 03:00:02 UTC
- Revision ID: daniel@percona.com-20140220030002-gsj22qr101mb2fbp
Remove version check bin type. Update all tools.
- files modified:
- bin/pt-agent
added
removed
bin/pt-archiver
27
27
TableNibbler
28
28
Daemon
29
29
MasterSlave
30
HTTPMicro
30
HTTP::Micro
31
31
VersionCheck
32
32
));
33
33
}
4199
4199
# ###########################################################################
4200
4200
4201
4201
# ###########################################################################
4202
# HTTPMicro package
4202
# HTTP::Micro package
4203
4203
# This package is a copy without comments from the original. The original
4204
4204
# with comments and its test file can be found in the Bazaar repository at,
4205
# lib/HTTPMicro.pm
4206
# t/lib/HTTPMicro.t
4205
# lib/HTTP/Micro.pm
4206
# t/lib/HTTP/Micro.t
4207
4207
# See https://launchpad.net/percona-toolkit for more information.
4208
4208
# ###########################################################################
4209
4209
{
4210
4211
package HTTPMicro;
4212
BEGIN {
4213
$HTTPMicro::VERSION = '0.001';
4214
}
4210
package HTTP::Micro;
4211
4212
our $VERSION = '0.01';
4213
4215
4214
use strict;
4216
use warnings;
4217
4215
use warnings FATAL => 'all';
4216
use English qw(-no_match_vars);
4218
4217
use Carp ();
4219
4218
4220
4221
4219
my @attributes;
4222
4220
BEGIN {
4223
4221
@attributes = qw(agent timeout);
4288
4286
headers => {},
4289
4287
};
4290
4288
4291
my $handle = HTTPMicro::Handle->new(timeout => $self->{timeout});
4289
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
4292
4290
4293
4291
$handle->connect($scheme, $host, $port);
4294
4292
4353
4351
return ($scheme, $host, $port, $path_query);
4354
4352
}
4355
4353
4356
package
4357
HTTPMicro::Handle; # hide from PAUSE/indexers
4358
use strict;
4359
use warnings;
4360
4361
use Carp qw[croak];
4362
use Errno qw[EINTR EPIPE];
4363
use IO::Socket qw[SOCK_STREAM];
4364
4365
sub BUFSIZE () { 32768 }
4366
4367
my $Printable = sub {
4368
local $_ = shift;
4369
s/\r/\\r/g;
4370
s/\n/\\n/g;
4371
s/\t/\\t/g;
4372
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
4373
$_;
4374
};
4375
4376
sub new {
4377
my ($class, %args) = @_;
4378
return bless {
4379
rbuf => '',
4380
timeout => 60,
4381
max_line_size => 16384,
4382
%args
4383
}, $class;
4384
}
4385
4386
my $ssl_verify_args = {
4387
check_cn => "when_only",
4388
wildcards_in_alt => "anywhere",
4389
wildcards_in_cn => "anywhere"
4390
};
4391
4392
sub connect {
4393
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
4394
my ($self, $scheme, $host, $port) = @_;
4395
4396
if ( $scheme eq 'https' ) {
4397
eval "require IO::Socket::SSL"
4398
unless exists $INC{'IO/Socket/SSL.pm'};
4399
croak(qq/IO::Socket::SSL must be installed for https support\n/)
4400
unless $INC{'IO/Socket/SSL.pm'};
4401
}
4402
elsif ( $scheme ne 'http' ) {
4403
croak(qq/Unsupported URL scheme '$scheme'\n/);
4404
}
4405
4406
$self->{fh} = 'IO::Socket::INET'->new(
4407
PeerHost => $host,
4408
PeerPort => $port,
4409
Proto => 'tcp',
4410
Type => SOCK_STREAM,
4411
Timeout => $self->{timeout}
4412
) or croak(qq/Could not connect to '$host:$port': $@/);
4413
4414
binmode($self->{fh})
4415
or croak(qq/Could not binmode() socket: '$!'/);
4416
4417
if ( $scheme eq 'https') {
4418
IO::Socket::SSL->start_SSL($self->{fh});
4419
ref($self->{fh}) eq 'IO::Socket::SSL'
4420
or die(qq/SSL connection failed for $host\n/);
4421
if ( $self->{fh}->can("verify_hostname") ) {
4422
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
4423
}
4424
else {
4425
my $fh = $self->{fh};
4426
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
4427
or die(qq/SSL certificate not valid for $host\n/);
4428
}
4429
}
4430
4431
$self->{host} = $host;
4432
$self->{port} = $port;
4433
4434
return $self;
4435
}
4436
4437
sub close {
4438
@_ == 1 || croak(q/Usage: $handle->close()/);
4439
my ($self) = @_;
4440
CORE::close($self->{fh})
4441
or croak(qq/Could not close socket: '$!'/);
4442
}
4443
4444
sub write {
4445
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
4446
my ($self, $buf) = @_;
4447
4448
my $len = length $buf;
4449
my $off = 0;
4450
4451
local $SIG{PIPE} = 'IGNORE';
4452
4453
while () {
4454
$self->can_write
4455
or croak(q/Timed out while waiting for socket to become ready for writing/);
4456
my $r = syswrite($self->{fh}, $buf, $len, $off);
4457
if (defined $r) {
4458
$len -= $r;
4459
$off += $r;
4460
last unless $len > 0;
4461
}
4462
elsif ($! == EPIPE) {
4463
croak(qq/Socket closed by remote server: $!/);
4464
}
4465
elsif ($! != EINTR) {
4466
croak(qq/Could not write to socket: '$!'/);
4467
}
4468
}
4469
return $off;
4470
}
4471
4472
sub read {
4473
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
4474
my ($self, $len) = @_;
4475
4476
my $buf = '';
4477
my $got = length $self->{rbuf};
4478
4479
if ($got) {
4480
my $take = ($got < $len) ? $got : $len;
4481
$buf = substr($self->{rbuf}, 0, $take, '');
4482
$len -= $take;
4483
}
4484
4485
while ($len > 0) {
4486
$self->can_read
4487
or croak(q/Timed out while waiting for socket to become ready for reading/);
4488
my $r = sysread($self->{fh}, $buf, $len, length $buf);
4489
if (defined $r) {
4490
last unless $r;
4491
$len -= $r;
4492
}
4493
elsif ($! != EINTR) {
4494
croak(qq/Could not read from socket: '$!'/);
4495
}
4496
}
4497
if ($len) {
4498
croak(q/Unexpected end of stream/);
4499
}
4500
return $buf;
4501
}
4502
4503
sub readline {
4504
@_ == 1 || croak(q/Usage: $handle->readline()/);
4505
my ($self) = @_;
4506
4507
while () {
4508
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
4509
return $1;
4510
}
4511
$self->can_read
4512
or croak(q/Timed out while waiting for socket to become ready for reading/);
4513
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
4514
if (defined $r) {
4515
last unless $r;
4516
}
4517
elsif ($! != EINTR) {
4518
croak(qq/Could not read from socket: '$!'/);
4519
}
4520
}
4521
croak(q/Unexpected end of stream while looking for line/);
4522
}
4523
4524
sub read_header_lines {
4525
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
4526
my ($self, $headers) = @_;
4527
$headers ||= {};
4528
my $lines = 0;
4529
my $val;
4530
4531
while () {
4532
my $line = $self->readline;
4533
4534
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
4535
my ($field_name) = lc $1;
4536
$val = \($headers->{$field_name} = $2);
4537
}
4538
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
4539
$val
4540
or croak(q/Unexpected header continuation line/);
4541
next unless length $1;
4542
$$val .= ' ' if length $$val;
4543
$$val .= $1;
4544
}
4545
elsif ($line =~ /\A \x0D?\x0A \z/x) {
4546
last;
4547
}
4548
else {
4549
croak(q/Malformed header line: / . $Printable->($line));
4550
}
4551
}
4552
return $headers;
4553
}
4554
4555
sub write_header_lines {
4556
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
4557
my($self, $headers) = @_;
4558
4559
my $buf = '';
4560
while (my ($k, $v) = each %$headers) {
4561
my $field_name = lc $k;
4562
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
4563
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
4564
$field_name =~ s/\b(\w)/\u$1/g;
4565
$buf .= "$field_name: $v\x0D\x0A";
4566
}
4567
$buf .= "\x0D\x0A";
4568
return $self->write($buf);
4569
}
4570
4571
sub read_content_body {
4572
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
4573
my ($self, $cb, $response, $len) = @_;
4574
$len ||= $response->{headers}{'content-length'};
4575
4576
croak("No content-length in the returned response, and this "
4577
. "UA doesn't implement chunking") unless defined $len;
4578
4579
while ($len > 0) {
4580
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
4581
$cb->($self->read($read), $response);
4582
$len -= $read;
4583
}
4584
4585
return;
4586
}
4587
4588
sub write_content_body {
4589
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
4590
my ($self, $request) = @_;
4591
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
4592
4593
$len += $self->write($request->{content});
4594
4595
$len == $content_length
4596
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
4597
4598
return $len;
4599
}
4600
4601
sub read_response_header {
4602
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
4603
my ($self) = @_;
4604
4605
my $line = $self->readline;
4606
4607
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
4608
or croak(q/Malformed Status-Line: / . $Printable->($line));
4609
4610
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
4611
4612
return {
4613
status => $status,
4614
reason => $reason,
4615
headers => $self->read_header_lines,
4616
protocol => $protocol,
4617
};
4618
}
4619
4620
sub write_request_header {
4621
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
4622
my ($self, $method, $request_uri, $headers) = @_;
4623
4624
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
4625
+ $self->write_header_lines($headers);
4626
}
4627
4628
sub _do_timeout {
4629
my ($self, $type, $timeout) = @_;
4630
$timeout = $self->{timeout}
4631
unless defined $timeout && $timeout >= 0;
4632
4633
my $fd = fileno $self->{fh};
4634
defined $fd && $fd >= 0
4635
or croak(q/select(2): 'Bad file descriptor'/);
4636
4637
my $initial = time;
4638
my $pending = $timeout;
4639
my $nfound;
4640
4641
vec(my $fdset = '', $fd, 1) = 1;
4642
4643
while () {
4644
$nfound = ($type eq 'read')
4645
? select($fdset, undef, undef, $pending)
4646
: select(undef, $fdset, undef, $pending) ;
4647
if ($nfound == -1) {
4648
$! == EINTR
4649
or croak(qq/select(2): '$!'/);
4650
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
4651
$nfound = 0;
4652
}
4653
last;
4654
}
4655
$! = 0;
4656
return $nfound;
4657
}
4658
4659
sub can_read {
4660
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
4661
my $self = shift;
4662
return $self->_do_timeout('read', @_)
4663
}
4664
4665
sub can_write {
4666
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
4667
my $self = shift;
4668
return $self->_do_timeout('write', @_)
4669
}
4354
} # HTTP::Micro
4355
4356
{
4357
package HTTP::Micro::Handle;
4358
4359
use strict;
4360
use warnings FATAL => 'all';
4361
use English qw(-no_match_vars);
4362
4363
use Carp qw(croak);
4364
use Errno qw(EINTR EPIPE);
4365
use IO::Socket qw(SOCK_STREAM);
4366
4367
sub BUFSIZE () { 32768 }
4368
4369
my $Printable = sub {
4370
local $_ = shift;
4371
s/\r/\\r/g;
4372
s/\n/\\n/g;
4373
s/\t/\\t/g;
4374
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
4375
$_;
4376
};
4377
4378
sub new {
4379
my ($class, %args) = @_;
4380
return bless {
4381
rbuf => '',
4382
timeout => 60,
4383
max_line_size => 16384,
4384
%args
4385
}, $class;
4386
}
4387
4388
my $ssl_verify_args = {
4389
check_cn => "when_only",
4390
wildcards_in_alt => "anywhere",
4391
wildcards_in_cn => "anywhere"
4392
};
4393
4394
sub connect {
4395
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
4396
my ($self, $scheme, $host, $port) = @_;
4397
4398
if ( $scheme eq 'https' ) {
4399
eval "require IO::Socket::SSL"
4400
unless exists $INC{'IO/Socket/SSL.pm'};
4401
croak(qq/IO::Socket::SSL must be installed for https support\n/)
4402
unless $INC{'IO/Socket/SSL.pm'};
4403
}
4404
elsif ( $scheme ne 'http' ) {
4405
croak(qq/Unsupported URL scheme '$scheme'\n/);
4406
}
4407
4408
$self->{fh} = IO::Socket::INET->new(
4409
PeerHost => $host,
4410
PeerPort => $port,
4411
Proto => 'tcp',
4412
Type => SOCK_STREAM,
4413
Timeout => $self->{timeout}
4414
) or croak(qq/Could not connect to '$host:$port': $@/);
4415
4416
binmode($self->{fh})
4417
or croak(qq/Could not binmode() socket: '$!'/);
4418
4419
if ( $scheme eq 'https') {
4420
IO::Socket::SSL->start_SSL($self->{fh});
4421
ref($self->{fh}) eq 'IO::Socket::SSL'
4422
or die(qq/SSL connection failed for $host\n/);
4423
if ( $self->{fh}->can("verify_hostname") ) {
4424
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
4425
}
4426
else {
4427
my $fh = $self->{fh};
4428
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
4429
or die(qq/SSL certificate not valid for $host\n/);
4430
}
4431
}
4432
4433
$self->{host} = $host;
4434
$self->{port} = $port;
4435
4436
return $self;
4437
}
4438
4439
sub close {
4440
@_ == 1 || croak(q/Usage: $handle->close()/);
4441
my ($self) = @_;
4442
CORE::close($self->{fh})
4443
or croak(qq/Could not close socket: '$!'/);
4444
}
4445
4446
sub write {
4447
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
4448
my ($self, $buf) = @_;
4449
4450
my $len = length $buf;
4451
my $off = 0;
4452
4453
local $SIG{PIPE} = 'IGNORE';
4454
4455
while () {
4456
$self->can_write
4457
or croak(q/Timed out while waiting for socket to become ready for writing/);
4458
my $r = syswrite($self->{fh}, $buf, $len, $off);
4459
if (defined $r) {
4460
$len -= $r;
4461
$off += $r;
4462
last unless $len > 0;
4463
}
4464
elsif ($! == EPIPE) {
4465
croak(qq/Socket closed by remote server: $!/);
4466
}
4467
elsif ($! != EINTR) {
4468
croak(qq/Could not write to socket: '$!'/);
4469
}
4470
}
4471
return $off;
4472
}
4473
4474
sub read {
4475
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
4476
my ($self, $len) = @_;
4477
4478
my $buf = '';
4479
my $got = length $self->{rbuf};
4480
4481
if ($got) {
4482
my $take = ($got < $len) ? $got : $len;
4483
$buf = substr($self->{rbuf}, 0, $take, '');
4484
$len -= $take;
4485
}
4486
4487
while ($len > 0) {
4488
$self->can_read
4489
or croak(q/Timed out while waiting for socket to become ready for reading/);
4490
my $r = sysread($self->{fh}, $buf, $len, length $buf);
4491
if (defined $r) {
4492
last unless $r;
4493
$len -= $r;
4494
}
4495
elsif ($! != EINTR) {
4496
croak(qq/Could not read from socket: '$!'/);
4497
}
4498
}
4499
if ($len) {
4500
croak(q/Unexpected end of stream/);
4501
}
4502
return $buf;
4503
}
4504
4505
sub readline {
4506
@_ == 1 || croak(q/Usage: $handle->readline()/);
4507
my ($self) = @_;
4508
4509
while () {
4510
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
4511
return $1;
4512
}
4513
$self->can_read
4514
or croak(q/Timed out while waiting for socket to become ready for reading/);
4515
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
4516
if (defined $r) {
4517
last unless $r;
4518
}
4519
elsif ($! != EINTR) {
4520
croak(qq/Could not read from socket: '$!'/);
4521
}
4522
}
4523
croak(q/Unexpected end of stream while looking for line/);
4524
}
4525
4526
sub read_header_lines {
4527
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
4528
my ($self, $headers) = @_;
4529
$headers ||= {};
4530
my $lines = 0;
4531
my $val;
4532
4533
while () {
4534
my $line = $self->readline;
4535
4536
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
4537
my ($field_name) = lc $1;
4538
$val = \($headers->{$field_name} = $2);
4539
}
4540
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
4541
$val
4542
or croak(q/Unexpected header continuation line/);
4543
next unless length $1;
4544
$$val .= ' ' if length $$val;
4545
$$val .= $1;
4546
}
4547
elsif ($line =~ /\A \x0D?\x0A \z/x) {
4548
last;
4549
}
4550
else {
4551
croak(q/Malformed header line: / . $Printable->($line));
4552
}
4553
}
4554
return $headers;
4555
}
4556
4557
sub write_header_lines {
4558
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
4559
my($self, $headers) = @_;
4560
4561
my $buf = '';
4562
while (my ($k, $v) = each %$headers) {
4563
my $field_name = lc $k;
4564
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
4565
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
4566
$field_name =~ s/\b(\w)/\u$1/g;
4567
$buf .= "$field_name: $v\x0D\x0A";
4568
}
4569
$buf .= "\x0D\x0A";
4570
return $self->write($buf);
4571
}
4572
4573
sub read_content_body {
4574
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
4575
my ($self, $cb, $response, $len) = @_;
4576
$len ||= $response->{headers}{'content-length'};
4577
4578
croak("No content-length in the returned response, and this "
4579
. "UA doesn't implement chunking") unless defined $len;
4580
4581
while ($len > 0) {
4582
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
4583
$cb->($self->read($read), $response);
4584
$len -= $read;
4585
}
4586
4587
return;
4588
}
4589
4590
sub write_content_body {
4591
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
4592
my ($self, $request) = @_;
4593
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
4594
4595
$len += $self->write($request->{content});
4596
4597
$len == $content_length
4598
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
4599
4600
return $len;
4601
}
4602
4603
sub read_response_header {
4604
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
4605
my ($self) = @_;
4606
4607
my $line = $self->readline;
4608
4609
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
4610
or croak(q/Malformed Status-Line: / . $Printable->($line));
4611
4612
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
4613
4614
return {
4615
status => $status,
4616
reason => $reason,
4617
headers => $self->read_header_lines,
4618
protocol => $protocol,
4619
};
4620
}
4621
4622
sub write_request_header {
4623
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
4624
my ($self, $method, $request_uri, $headers) = @_;
4625
4626
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
4627
+ $self->write_header_lines($headers);
4628
}
4629
4630
sub _do_timeout {
4631
my ($self, $type, $timeout) = @_;
4632
$timeout = $self->{timeout}
4633
unless defined $timeout && $timeout >= 0;
4634
4635
my $fd = fileno $self->{fh};
4636
defined $fd && $fd >= 0
4637
or croak(q/select(2): 'Bad file descriptor'/);
4638
4639
my $initial = time;
4640
my $pending = $timeout;
4641
my $nfound;
4642
4643
vec(my $fdset = '', $fd, 1) = 1;
4644
4645
while () {
4646
$nfound = ($type eq 'read')
4647
? select($fdset, undef, undef, $pending)
4648
: select(undef, $fdset, undef, $pending) ;
4649
if ($nfound == -1) {
4650
$! == EINTR
4651
or croak(qq/select(2): '$!'/);
4652
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
4653
$nfound = 0;
4654
}
4655
last;
4656
}
4657
$! = 0;
4658
return $nfound;
4659
}
4660
4661
sub can_read {
4662
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
4663
my $self = shift;
4664
return $self->_do_timeout('read', @_)
4665
}
4666
4667
sub can_write {
4668
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
4669
my $self = shift;
4670
return $self->_do_timeout('write', @_)
4671
}
4672
} # HTTP::Micro::Handle
4670
4673
4671
4674
my $prog = <<'EOP';
4672
4675
BEGIN {
4687
4690
}
4688
4691
}
4689
4692
{
4693
use Carp qw(croak);
4690
4694
my %dispatcher = (
4691
4695
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
4692
4696
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
4842
4846
}
4843
4847
4844
4848
1;
4845
}
4846
4849
# ###########################################################################
4847
# End HTTPMicro package
4850
# End HTTP::Micro package
4848
4851
# ###########################################################################
4849
4852
4850
4853
# ###########################################################################
4878
4881
4879
4882
eval {
4880
4883
require Percona::Toolkit;
4881
require HTTPMicro;
4884
require HTTP::Micro;
4882
4885
};
4883
4886
4884
4887
{
5109
5112
my $url = $args{url};
5110
5113
my $instances = $args{instances};
5111
5114
5112
my $ua = $args{ua} || HTTPMicro->new( timeout => 3 );
5115
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
5113
5116
5114
5117
my $response = $ua->request('GET', $url);
5115
5118
PTDEBUG && _d('Server response:', Dumper($response));
5223
5226
perl_version => \&get_perl_version,
5224
5227
perl_module_version => \&get_perl_module_version,
5225
5228
mysql_variable => \&get_mysql_variable,
5226
bin_version => \&get_bin_version,
5227
5229
);
5228
5230
5229
5231
sub valid_item {
5406
5408
return \%version_for;
5407
5409
}
5408
5410
5409
sub get_bin_version {
5410
my (%args) = @_;
5411
my $item = $args{item};
5412
my $cmd = $item->{item};
5413
return unless $cmd;
5414
5415
my $sanitized_command = File::Basename::basename($cmd);
5416
PTDEBUG && _d('cmd:', $cmd, 'sanitized:', $sanitized_command);
5417
return if $sanitized_command !~ /\A[a-zA-Z0-9_-]+\z/;
5418
5419
my $output = `$sanitized_command --version 2>&1`;
5420
PTDEBUG && _d('output:', $output);
5421
5422
my ($version) = $output =~ /v?([0-9]+\.[0-9]+(?:\.[\w-]+)?)/;
5423
5424
PTDEBUG && _d('Version for', $sanitized_command, '=', $version);
5425
return $version;
5426
}
5427
5428
5411
sub _d {
5429
5412
my ($package, undef, $line) = caller 0;
5430
5413
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
Loggerhead is a web-based interface for Breezy
Version: 2.0.1