~percona-toolkit-dev/percona-toolkit/changehandler-dont-hexify-text-cols
» Revision
365
: bin/pt-variable-advisor
« back to all changes in this revision
Viewing changes to bin/pt-variable-advisor
- browse files at revision 365
- compare with another revision
- download diff
- download tarball
- view history from revision 365
- Committer: Daniel Nichter
- Date: 2012-08-23 01:59:55 UTC
- mfrom: (350.1.29 pingback-feature)
- Revision ID: daniel@percona.com-20120823015955-5amltej7vn72sz9w
Merge lp:~percona-toolkit-dev/percona-toolkit/pingback-feature
- files added:
- lib/HTTPMicro.pm
- lib/Percona
- files modified:
- bin/pt-archiver
added
removed
bin/pt-variable-advisor
6
6
7
7
use strict;
8
8
use warnings FATAL => 'all';
9
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
9
10
# This tool is "fat-packed": most of its dependent modules are embedded
11
# in this file. Setting %INC to this file for each module makes Perl aware
12
# of this so it will not try to load the module from @INC. See the tool's
13
# documentation for a full list of dependencies.
14
BEGIN {
15
$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
16
Percona::Toolkit
17
OptionParser
18
Mo
19
DSNParser
20
VersionParser
21
Daemon
22
PodParser
23
TextResultSetParser
24
Advisor
25
AdvisorRules
26
VariableAdvisorRules
27
VersionCheck
28
HTTPMicro
29
Pingback
30
));
31
}
32
33
# ###########################################################################
34
# Percona::Toolkit package
35
# This package is a copy without comments from the original. The original
36
# with comments and its test file can be found in the Bazaar repository at,
37
# lib/Percona/Toolkit.pm
38
# t/lib/Percona/Toolkit.t
39
# See https://launchpad.net/percona-toolkit for more information.
40
# ###########################################################################
41
{
42
package Percona::Toolkit;
43
our $VERSION = '2.1.3';
44
1;
45
}
46
# ###########################################################################
47
# End Percona::Toolkit package
48
# ###########################################################################
10
49
11
50
# ###########################################################################
12
51
# OptionParser package
3381
3420
# ###########################################################################
3382
3421
3383
3422
# ###########################################################################
3423
# VersionCheck package
3424
# This package is a copy without comments from the original. The original
3425
# with comments and its test file can be found in the Bazaar repository at,
3426
# lib/VersionCheck.pm
3427
# t/lib/VersionCheck.t
3428
# See https://launchpad.net/percona-toolkit for more information.
3429
# ###########################################################################
3430
{
3431
package VersionCheck;
3432
3433
use strict;
3434
use warnings FATAL => 'all';
3435
use English qw(-no_match_vars);
3436
3437
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3438
3439
use File::Basename ();
3440
use Data::Dumper ();
3441
3442
sub Dumper {
3443
local $Data::Dumper::Indent = 1;
3444
local $Data::Dumper::Sortkeys = 1;
3445
local $Data::Dumper::Quotekeys = 0;
3446
3447
Data::Dumper::Dumper(@_);
3448
}
3449
3450
sub new {
3451
my ($class, %args) = @_;
3452
my $self = {
3453
valid_types => qr/
3454
^(?:
3455
os_version
3456
|perl_version
3457
|perl_module_version
3458
|mysql_variable
3459
|bin_version
3460
)$/x,
3461
};
3462
return bless $self, $class;
3463
}
3464
3465
sub parse_server_response {
3466
my ($self, %args) = @_;
3467
my @required_args = qw(response);
3468
foreach my $arg ( @required_args ) {
3469
die "I need a $arg arugment" unless $args{$arg};
3470
}
3471
my ($response) = @args{@required_args};
3472
3473
my %items = map {
3474
my ($item, $type, $vars) = split(";", $_);
3475
if ( !defined $args{split_vars} || $args{split_vars} ) {
3476
$vars = [ split(",", ($vars || '')) ];
3477
}
3478
$item => {
3479
item => $item,
3480
type => $type,
3481
vars => $vars,
3482
};
3483
} split("\n", $response);
3484
3485
PTDEBUG && _d('Items:', Dumper(\%items));
3486
3487
return \%items;
3488
}
3489
3490
sub get_versions {
3491
my ($self, %args) = @_;
3492
my @required_args = qw(items);
3493
foreach my $arg ( @required_args ) {
3494
die "I need a $arg arugment" unless $args{$arg};
3495
}
3496
my ($items) = @args{@required_args};
3497
my $dbh = $args{dbh}; # optional
3498
3499
my %versions;
3500
foreach my $item ( values %$items ) {
3501
next unless $self->valid_item($item);
3502
3503
eval {
3504
my $func = 'get_' . $item->{type};
3505
my $version = $self->$func(
3506
item => $item,
3507
dbh => $dbh,
3508
);
3509
if ( $version ) {
3510
chomp $version;
3511
$versions{$item->{item}} = $version;
3512
}
3513
};
3514
if ( $EVAL_ERROR ) {
3515
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
3516
}
3517
}
3518
3519
return \%versions;
3520
}
3521
3522
sub valid_item {
3523
my ($self, $item) = @_;
3524
return unless $item;
3525
3526
if ( ($item->{type} || '') !~ m/$self->{valid_types}/ ) {
3527
PTDEBUG && _d('Invalid type:', $item->{type});
3528
return;
3529
}
3530
3531
return 1;
3532
}
3533
3534
sub get_os_version {
3535
my ($self) = @_;
3536
3537
chomp(my $platform = `uname -s`);
3538
PTDEBUG && _d('platform:', $platform);
3539
return $OSNAME unless $platform;
3540
3541
chomp(my $lsb_release
3542
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
3543
PTDEBUG && _d('lsb_release:', $lsb_release);
3544
3545
my $release = "";
3546
3547
if ( $platform eq 'Linux' ) {
3548
if ( -f "/etc/fedora-release" ) {
3549
$release = `cat /etc/fedora-release`;
3550
}
3551
elsif ( -f "/etc/redhat-release" ) {
3552
$release = `cat /etc/redhat-release`;
3553
}
3554
elsif ( -f "/etc/system-release" ) {
3555
$release = `cat /etc/system-release`;
3556
}
3557
elsif ( $lsb_release ) {
3558
$release = `$lsb_release -ds`;
3559
}
3560
elsif ( -f "/etc/lsb-release" ) {
3561
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
3562
$release =~ s/^\w+="([^"]+)".+/$1/;
3563
}
3564
elsif ( -f "/etc/debian_version" ) {
3565
chomp(my $rel = `cat /etc/debian_version`);
3566
$release = "Debian $rel";
3567
if ( -f "/etc/apt/sources.list" ) {
3568
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}'`);
3569
$release .= " ($code_name)" if $code_name;
3570
}
3571
}
3572
elsif ( `ls /etc/*release 2>/dev/null` ) {
3573
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
3574
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
3575
}
3576
else {
3577
$release = `cat /etc/*release | head -n1`;
3578
}
3579
}
3580
}
3581
elsif ( $platform =~ m/^(BSD|Darwin)$/ ) {
3582
my $rel = `uname -r`;
3583
$release = "$platform $rel";
3584
}
3585
elsif ( $platform eq "SunOS" ) {
3586
my $rel = `head -n1 /etc/release` || `uname -r`;
3587
$release = "$platform $rel";
3588
}
3589
3590
if ( !$release ) {
3591
PTDEBUG && _d('Failed to get the release, using platform');
3592
$release = $platform;
3593
}
3594
chomp($release);
3595
3596
PTDEBUG && _d('OS version =', $release);
3597
return $release;
3598
}
3599
3600
sub get_perl_version {
3601
my ($self, %args) = @_;
3602
my $item = $args{item};
3603
return unless $item;
3604
3605
my $version = sprintf '%vd', $PERL_VERSION;
3606
PTDEBUG && _d('Perl version', $version);
3607
return $version;
3608
}
3609
3610
sub get_perl_module_version {
3611
my ($self, %args) = @_;
3612
my $item = $args{item};
3613
return unless $item;
3614
3615
my $var = $item->{item} . '::VERSION';
3616
my $version = _get_scalar($var);
3617
PTDEBUG && _d('Perl version for', $var, '=', "$version");
3618
3619
return $version ? "$version" : $version;
3620
}
3621
3622
sub _get_scalar {
3623
no strict;
3624
return ${*{shift()}};
3625
}
3626
3627
sub get_mysql_variable {
3628
my $self = shift;
3629
return $self->_get_from_mysql(
3630
show => 'VARIABLES',
3631
@_,
3632
);
3633
}
3634
3635
3636
sub _get_from_mysql {
3637
my ($self, %args) = @_;
3638
my $show = $args{show};
3639
my $item = $args{item};
3640
my $dbh = $args{dbh};
3641
return unless $show && $item && $dbh;
3642
3643
local $dbh->{FetchHashKeyName} = 'NAME_lc';
3644
my $sql = qq/SHOW $show/;
3645
PTDEBUG && _d($sql);
3646
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
3647
3648
my @versions;
3649
foreach my $var ( @{$item->{vars}} ) {
3650
$var = lc($var);
3651
my $version = $rows->{$var}->{value};
3652
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version);
3653
push @versions, $version;
3654
}
3655
3656
return join(' ', @versions);
3657
}
3658
3659
sub get_bin_version {
3660
my ($self, %args) = @_;
3661
my $item = $args{item};
3662
my $cmd = $item->{item};
3663
return unless $cmd;
3664
3665
my $sanitized_command = File::Basename::basename($cmd);
3666
PTDEBUG && _d('cmd:', $cmd, 'sanitized:', $sanitized_command);
3667
return if $sanitized_command !~ /\A[a-zA-Z0-9_-]+\z/;
3668
3669
my $output = `$sanitized_command --version 2>&1`;
3670
PTDEBUG && _d('output:', $output);
3671
3672
my ($version) = $output =~ /v?([0-9]+\.[0-9]+(?:\.[\w-]+)?)/;
3673
3674
PTDEBUG && _d('Version for', $sanitized_command, '=', $version);
3675
return $version;
3676
}
3677
3678
sub _d {
3679
my ($package, undef, $line) = caller 0;
3680
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3681
map { defined $_ ? $_ : 'undef' }
3682
@_;
3683
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3684
}
3685
3686
1;
3687
}
3688
# ###########################################################################
3689
# End VersionCheck package
3690
# ###########################################################################
3691
3692
# ###########################################################################
3693
# HTTPMicro package
3694
# This package is a copy without comments from the original. The original
3695
# with comments and its test file can be found in the Bazaar repository at,
3696
# lib/HTTPMicro.pm
3697
# t/lib/HTTPMicro.t
3698
# See https://launchpad.net/percona-toolkit for more information.
3699
# ###########################################################################
3700
{
3701
3702
package HTTPMicro;
3703
BEGIN {
3704
$HTTPMicro::VERSION = '0.001';
3705
}
3706
use strict;
3707
use warnings;
3708
3709
use Carp ();
3710
3711
3712
my @attributes;
3713
BEGIN {
3714
@attributes = qw(agent timeout);
3715
no strict 'refs';
3716
for my $accessor ( @attributes ) {
3717
*{$accessor} = sub {
3718
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
3719
};
3720
}
3721
}
3722
3723
sub new {
3724
my($class, %args) = @_;
3725
(my $agent = $class) =~ s{::}{-}g;
3726
my $self = {
3727
agent => $agent . "/" . ($class->VERSION || 0),
3728
timeout => 60,
3729
};
3730
for my $key ( @attributes ) {
3731
$self->{$key} = $args{$key} if exists $args{$key}
3732
}
3733
return bless $self, $class;
3734
}
3735
3736
sub request {
3737
my ($self, $method, $url, $args) = @_;
3738
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
3739
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
3740
$args ||= {}; # we keep some state in this during _request
3741
3742
my $response;
3743
for ( 0 .. 1 ) {
3744
$response = eval { $self->_request($method, $url, $args) };
3745
last unless $@ && $method eq 'GET'
3746
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
3747
}
3748
3749
if (my $e = "$@") {
3750
$response = {
3751
success => q{},
3752
status => 599,
3753
reason => 'Internal Exception',
3754
content => $e,
3755
headers => {
3756
'content-type' => 'text/plain',
3757
'content-length' => length $e,
3758
}
3759
};
3760
}
3761
return $response;
3762
}
3763
3764
sub _request {
3765
my ($self, $method, $url, $args) = @_;
3766
3767
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
3768
3769
my $request = {
3770
method => $method,
3771
scheme => $scheme,
3772
host_port => ($port == 80 ? $host : "$host:$port"),
3773
uri => $path_query,
3774
headers => {},
3775
};
3776
3777
my $handle = HTTPMicro::Handle->new(timeout => $self->{timeout});
3778
3779
$handle->connect($scheme, $host, $port);
3780
3781
$self->_prepare_headers_and_cb($request, $args);
3782
$handle->write_request_header(@{$request}{qw/method uri headers/});
3783
$handle->write_content_body($request) if $request->{content};
3784
3785
my $response;
3786
do { $response = $handle->read_response_header }
3787
until (substr($response->{status},0,1) ne '1');
3788
3789
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
3790
$response->{content} = '';
3791
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
3792
}
3793
3794
$handle->close;
3795
$response->{success} = substr($response->{status},0,1) eq '2';
3796
return $response;
3797
}
3798
3799
sub _prepare_headers_and_cb {
3800
my ($self, $request, $args) = @_;
3801
3802
for ($args->{headers}) {
3803
next unless defined;
3804
while (my ($k, $v) = each %$_) {
3805
$request->{headers}{lc $k} = $v;
3806
}
3807
}
3808
$request->{headers}{'host'} = $request->{host_port};
3809
$request->{headers}{'connection'} = "close";
3810
$request->{headers}{'user-agent'} ||= $self->{agent};
3811
3812
if (defined $args->{content}) {
3813
$request->{headers}{'content-type'} ||= "application/octet-stream";
3814
utf8::downgrade($args->{content}, 1)
3815
or Carp::croak(q/Wide character in request message body/);
3816
$request->{headers}{'content-length'} = length $args->{content};
3817
$request->{content} = $args->{content};
3818
}
3819
return;
3820
}
3821
3822
sub _split_url {
3823
my $url = pop;
3824
3825
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
3826
or Carp::croak(qq/Cannot parse URL: '$url'/);
3827
3828
$scheme = lc $scheme;
3829
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
3830
3831
my $host = (length($authority)) ? lc $authority : 'localhost';
3832
$host =~ s/\A[^@]*@//; # userinfo
3833
my $port = do {
3834
$host =~ s/:([0-9]*)\z// && length $1
3835
? $1
3836
: ($scheme eq 'http' ? 80 : undef);
3837
};
3838
3839
return ($scheme, $host, $port, $path_query);
3840
}
3841
3842
package
3843
HTTPMicro::Handle; # hide from PAUSE/indexers
3844
use strict;
3845
use warnings;
3846
3847
use Carp qw[croak];
3848
use Errno qw[EINTR EPIPE];
3849
use IO::Socket qw[SOCK_STREAM];
3850
3851
sub BUFSIZE () { 32768 }
3852
3853
my $Printable = sub {
3854
local $_ = shift;
3855
s/\r/\\r/g;
3856
s/\n/\\n/g;
3857
s/\t/\\t/g;
3858
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
3859
$_;
3860
};
3861
3862
sub new {
3863
my ($class, %args) = @_;
3864
return bless {
3865
rbuf => '',
3866
timeout => 60,
3867
max_line_size => 16384,
3868
%args
3869
}, $class;
3870
}
3871
3872
sub connect {
3873
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
3874
my ($self, $scheme, $host, $port) = @_;
3875
3876
if ( $scheme ne 'http' ) {
3877
croak(qq/Unsupported URL scheme '$scheme'/);
3878
}
3879
3880
$self->{fh} = 'IO::Socket::INET'->new(
3881
PeerHost => $host,
3882
PeerPort => $port,
3883
Proto => 'tcp',
3884
Type => SOCK_STREAM,
3885
Timeout => $self->{timeout}
3886
) or croak(qq/Could not connect to '$host:$port': $@/);
3887
3888
binmode($self->{fh})
3889
or croak(qq/Could not binmode() socket: '$!'/);
3890
3891
$self->{host} = $host;
3892
$self->{port} = $port;
3893
3894
return $self;
3895
}
3896
3897
sub close {
3898
@_ == 1 || croak(q/Usage: $handle->close()/);
3899
my ($self) = @_;
3900
CORE::close($self->{fh})
3901
or croak(qq/Could not close socket: '$!'/);
3902
}
3903
3904
sub write {
3905
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
3906
my ($self, $buf) = @_;
3907
3908
my $len = length $buf;
3909
my $off = 0;
3910
3911
local $SIG{PIPE} = 'IGNORE';
3912
3913
while () {
3914
$self->can_write
3915
or croak(q/Timed out while waiting for socket to become ready for writing/);
3916
my $r = syswrite($self->{fh}, $buf, $len, $off);
3917
if (defined $r) {
3918
$len -= $r;
3919
$off += $r;
3920
last unless $len > 0;
3921
}
3922
elsif ($! == EPIPE) {
3923
croak(qq/Socket closed by remote server: $!/);
3924
}
3925
elsif ($! != EINTR) {
3926
croak(qq/Could not write to socket: '$!'/);
3927
}
3928
}
3929
return $off;
3930
}
3931
3932
sub read {
3933
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
3934
my ($self, $len) = @_;
3935
3936
my $buf = '';
3937
my $got = length $self->{rbuf};
3938
3939
if ($got) {
3940
my $take = ($got < $len) ? $got : $len;
3941
$buf = substr($self->{rbuf}, 0, $take, '');
3942
$len -= $take;
3943
}
3944
3945
while ($len > 0) {
3946
$self->can_read
3947
or croak(q/Timed out while waiting for socket to become ready for reading/);
3948
my $r = sysread($self->{fh}, $buf, $len, length $buf);
3949
if (defined $r) {
3950
last unless $r;
3951
$len -= $r;
3952
}
3953
elsif ($! != EINTR) {
3954
croak(qq/Could not read from socket: '$!'/);
3955
}
3956
}
3957
if ($len) {
3958
croak(q/Unexpected end of stream/);
3959
}
3960
return $buf;
3961
}
3962
3963
sub readline {
3964
@_ == 1 || croak(q/Usage: $handle->readline()/);
3965
my ($self) = @_;
3966
3967
while () {
3968
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
3969
return $1;
3970
}
3971
$self->can_read
3972
or croak(q/Timed out while waiting for socket to become ready for reading/);
3973
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
3974
if (defined $r) {
3975
last unless $r;
3976
}
3977
elsif ($! != EINTR) {
3978
croak(qq/Could not read from socket: '$!'/);
3979
}
3980
}
3981
croak(q/Unexpected end of stream while looking for line/);
3982
}
3983
3984
sub read_header_lines {
3985
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
3986
my ($self, $headers) = @_;
3987
$headers ||= {};
3988
my $lines = 0;
3989
my $val;
3990
3991
while () {
3992
my $line = $self->readline;
3993
3994
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
3995
my ($field_name) = lc $1;
3996
$val = \($headers->{$field_name} = $2);
3997
}
3998
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
3999
$val
4000
or croak(q/Unexpected header continuation line/);
4001
next unless length $1;
4002
$$val .= ' ' if length $$val;
4003
$$val .= $1;
4004
}
4005
elsif ($line =~ /\A \x0D?\x0A \z/x) {
4006
last;
4007
}
4008
else {
4009
croak(q/Malformed header line: / . $Printable->($line));
4010
}
4011
}
4012
return $headers;
4013
}
4014
4015
sub write_header_lines {
4016
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
4017
my($self, $headers) = @_;
4018
4019
my $buf = '';
4020
while (my ($k, $v) = each %$headers) {
4021
my $field_name = lc $k;
4022
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
4023
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
4024
$field_name =~ s/\b(\w)/\u$1/g;
4025
$buf .= "$field_name: $v\x0D\x0A";
4026
}
4027
$buf .= "\x0D\x0A";
4028
return $self->write($buf);
4029
}
4030
4031
sub read_content_body {
4032
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
4033
my ($self, $cb, $response, $len) = @_;
4034
$len ||= $response->{headers}{'content-length'};
4035
4036
croak("No content-length in the returned response, and this "
4037
. "UA doesn't implement chunking") unless defined $len;
4038
4039
while ($len > 0) {
4040
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
4041
$cb->($self->read($read), $response);
4042
$len -= $read;
4043
}
4044
4045
return;
4046
}
4047
4048
sub write_content_body {
4049
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
4050
my ($self, $request) = @_;
4051
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
4052
4053
$len += $self->write($request->{content});
4054
4055
$len == $content_length
4056
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
4057
4058
return $len;
4059
}
4060
4061
sub read_response_header {
4062
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
4063
my ($self) = @_;
4064
4065
my $line = $self->readline;
4066
4067
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
4068
or croak(q/Malformed Status-Line: / . $Printable->($line));
4069
4070
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
4071
4072
return {
4073
status => $status,
4074
reason => $reason,
4075
headers => $self->read_header_lines,
4076
protocol => $protocol,
4077
};
4078
}
4079
4080
sub write_request_header {
4081
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
4082
my ($self, $method, $request_uri, $headers) = @_;
4083
4084
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
4085
+ $self->write_header_lines($headers);
4086
}
4087
4088
sub _do_timeout {
4089
my ($self, $type, $timeout) = @_;
4090
$timeout = $self->{timeout}
4091
unless defined $timeout && $timeout >= 0;
4092
4093
my $fd = fileno $self->{fh};
4094
defined $fd && $fd >= 0
4095
or croak(q/select(2): 'Bad file descriptor'/);
4096
4097
my $initial = time;
4098
my $pending = $timeout;
4099
my $nfound;
4100
4101
vec(my $fdset = '', $fd, 1) = 1;
4102
4103
while () {
4104
$nfound = ($type eq 'read')
4105
? select($fdset, undef, undef, $pending)
4106
: select(undef, $fdset, undef, $pending) ;
4107
if ($nfound == -1) {
4108
$! == EINTR
4109
or croak(qq/select(2): '$!'/);
4110
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
4111
$nfound = 0;
4112
}
4113
last;
4114
}
4115
$! = 0;
4116
return $nfound;
4117
}
4118
4119
sub can_read {
4120
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
4121
my $self = shift;
4122
return $self->_do_timeout('read', @_)
4123
}
4124
4125
sub can_write {
4126
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
4127
my $self = shift;
4128
return $self->_do_timeout('write', @_)
4129
}
4130
4131
1;
4132
}
4133
# ###########################################################################
4134
# End HTTPMicro package
4135
# ###########################################################################
4136
4137
# ###########################################################################
4138
# Pingback package
4139
# This package is a copy without comments from the original. The original
4140
# with comments and its test file can be found in the Bazaar repository at,
4141
# lib/Pingback.pm
4142
# t/lib/Pingback.t
4143
# See https://launchpad.net/percona-toolkit for more information.
4144
# ###########################################################################
4145
{
4146
package Pingback;
4147
4148
use strict;
4149
use warnings FATAL => 'all';
4150
use English qw(-no_match_vars);
4151
4152
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4153
4154
use File::Basename qw();
4155
use Data::Dumper qw();
4156
use Fcntl qw(:DEFAULT);
4157
4158
use File::Spec;
4159
4160
my $dir = File::Spec->tmpdir();
4161
my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check');
4162
my $check_time_limit = 60 * 60 * 24; # one day
4163
4164
sub Dumper {
4165
local $Data::Dumper::Indent = 1;
4166
local $Data::Dumper::Sortkeys = 1;
4167
local $Data::Dumper::Quotekeys = 0;
4168
4169
Data::Dumper::Dumper(@_);
4170
}
4171
4172
local $EVAL_ERROR;
4173
eval {
4174
require HTTPMicro;
4175
require VersionCheck;
4176
};
4177
4178
sub version_check {
4179
eval {
4180
if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) {
4181
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
4182
_d('--version-check is disabled by the PERCONA_VERSION_CHECK',
4183
'environment variable');
4184
}
4185
return;
4186
}
4187
4188
if ( !time_to_check($check_time_file) ) {
4189
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
4190
_d('It is not time to --version-checka again;',
4191
'only 1 check per', $check_time_limit, 'seconds, and the last',
4192
'check was performed on the modified time of', $check_time_file);
4193
}
4194
return;
4195
}
4196
4197
my $dbh = shift; # optional
4198
my $advice = pingback(
4199
url => $ENV{PERCONA_VERSION_CHECK_URL} || 'http://v.percona.com',
4200
dbh => $dbh,
4201
);
4202
if ( $advice ) {
4203
print "# Percona suggests these upgrades:\n";
4204
print join("\n", map { "# * $_" } @$advice);
4205
print "\n# Specify --no-version-check to disable these suggestions.\n\n";
4206
}
4207
elsif ( $ENV{PTVCDEBUG} || PTDEBUG ) {
4208
_d('--version-check worked, but there were no suggestions');
4209
}
4210
};
4211
if ( $EVAL_ERROR ) {
4212
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
4213
_d('Error doing --version-check:', $EVAL_ERROR);
4214
}
4215
}
4216
4217
return;
4218
}
4219
4220
sub pingback {
4221
my (%args) = @_;
4222
my @required_args = qw(url);
4223
foreach my $arg ( @required_args ) {
4224
die "I need a $arg arugment" unless $args{$arg};
4225
}
4226
my ($url) = @args{@required_args};
4227
4228
my ($dbh, $ua, $vc) = @args{qw(dbh ua VersionCheck)};
4229
4230
$ua ||= HTTPMicro->new( timeout => 2 );
4231
$vc ||= VersionCheck->new();
4232
4233
my $response = $ua->request('GET', $url);
4234
PTDEBUG && _d('Server response:', Dumper($response));
4235
die "No response from GET $url"
4236
if !$response;
4237
die "GET $url returned HTTP status $response->{status}; expected 200"
4238
if $response->{status} != 200;
4239
die "GET $url did not return any programs to check"
4240
if !$response->{content};
4241
4242
my $items = $vc->parse_server_response(
4243
response => $response->{content}
4244
);
4245
die "Failed to parse server requested programs: $response->{content}"
4246
if !scalar keys %$items;
4247
4248
my $versions = $vc->get_versions(
4249
items => $items,
4250
dbh => $dbh,
4251
);
4252
die "Failed to get any program versions; should have at least gotten Perl"
4253
if !scalar keys %$versions;
4254
4255
my $client_content = encode_client_response(
4256
items => $items,
4257
versions => $versions,
4258
);
4259
4260
my $client_response = {
4261
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
4262
content => $client_content,
4263
};
4264
PTDEBUG && _d('Client response:', Dumper($client_response));
4265
4266
$response = $ua->request('POST', $url, $client_response);
4267
PTDEBUG && _d('Server suggestions:', Dumper($response));
4268
die "No response from POST $url $client_response"
4269
if !$response;
4270
die "POST $url returned HTTP status $response->{status}; expected 200"
4271
if $response->{status} != 200;
4272
4273
return unless $response->{content};
4274
4275
$items = $vc->parse_server_response(
4276
response => $response->{content},
4277
split_vars => 0,
4278
);
4279
die "Failed to parse server suggestions: $response->{content}"
4280
if !scalar keys %$items;
4281
my @suggestions = map { $_->{vars} }
4282
sort { $a->{item} cmp $b->{item} }
4283
values %$items;
4284
4285
return \@suggestions;
4286
}
4287
4288
sub time_to_check {
4289
my ($file) = @_;
4290
die "I need a file argument" unless $file;
4291
4292
if ( !-f $file ) {
4293
PTDEBUG && _d('Creating', $file);
4294
_touch($file);
4295
return 1;
4296
}
4297
4298
my $mtime = (stat $file)[9];
4299
if ( !defined $mtime ) {
4300
PTDEBUG && _d('Error getting modified time of', $file);
4301
return 0;
4302
}
4303
4304
my $time = int(time());
4305
PTDEBUG && _d('time=', $time, 'mtime=', $mtime);
4306
if ( ($time - $mtime) > $check_time_limit ) {
4307
_touch($file);
4308
return 1;
4309
}
4310
4311
return 0;
4312
}
4313
4314
sub _touch {
4315
my ($file) = @_;
4316
sysopen my $fh, $file, O_WRONLY|O_CREAT|O_NONBLOCK
4317
or die "Cannot create $file : $!";
4318
close $fh or die "Cannot close $file : $!";
4319
utime(undef, undef, $file);
4320
}
4321
4322
sub encode_client_response {
4323
my (%args) = @_;
4324
my @required_args = qw(items versions);
4325
foreach my $arg ( @required_args ) {
4326
die "I need a $arg arugment" unless $args{$arg};
4327
}
4328
my ($items, $versions) = @args{@required_args};
4329
4330
my @lines;
4331
foreach my $item ( sort keys %$items ) {
4332
next unless exists $versions->{$item};
4333
push @lines, join(';', $item, $versions->{$item});
4334
}
4335
4336
my $client_response = join("\n", @lines) . "\n";
4337
PTDEBUG && _d('Client response:', $client_response);
4338
return $client_response;
4339
}
4340
4341
sub _d {
4342
my ($package, undef, $line) = caller 0;
4343
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4344
map { defined $_ ? $_ : 'undef' }
4345
@_;
4346
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4347
}
4348
4349
1;
4350
}
4351
# ###########################################################################
4352
# End Pingback package
4353
# ###########################################################################
4354
4355
# ###########################################################################
3384
4356
# This is a combination of modules and programs in one -- a runnable module.
3385
4357
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
3386
4358
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
3393
4365
use strict;
3394
4366
use warnings FATAL => 'all';
3395
4367
use English qw(-no_match_vars);
4368
4369
use Percona::Toolkit;
3396
4370
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
3397
4371
3398
4372
sub main {
3399
@ARGV = @_; # set global ARGV for this package
4373
local @ARGV = @_; # set global ARGV for this package
3400
4374
3401
4375
# ########################################################################
3402
4376
# Get configuration information.
3491
4465
$daemon->make_PID_file();
3492
4466
}
3493
4467
4468
# ########################################################################
4469
# Do the version-check
4470
# ########################################################################
4471
if ( $o->get('version-check') && ($o->has('quiet') && !$o->get('quiet')) ) {
4472
Pingback::version_check($dbh);
4473
}
4474
3494
4475
# #########################################################################
3495
4476
# Get the variables and other MySQL info to pass to rules.
3496
4477
# #########################################################################
4314
5295
4315
5296
Show version and exit.
4316
5297
5298
=item --[no]version-check
5299
5300
default: yes
5301
5302
Send program versions to Percona and print suggested upgrades and problems.
5303
5304
The version check feature causes the tool to send and receive data from
5305
Percona over the web. The data contains program versions from the local
5306
machine. Percona uses the data to focus development on the most widely
5307
used versions of programs, and to suggest to customers possible upgrades
5308
and known bad versions of programs.
5309
5310
This feature can be disabled by specifying C<--no-version-check> on the
5311
command line or in one of several L<"--config"> files, or by setting the
5312
environment variable C<PERCONA_VERSION_CHECK=0>.
5313
5314
For more information, visit L<http://www.percona.com/version-check>.
5315
4317
5316
=back
4318
5317
4319
5318
=head1 DSN OPTIONS
Loggerhead is a web-based interface for Breezy
Version: 2.0.1