~percona-toolkit-dev/percona-toolkit/changehandler-dont-hexify-text-cols
» Revision
365
: bin/pt-fk-error-logger
« back to all changes in this revision
Viewing changes to bin/pt-fk-error-logger
- 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-fk-error-logger
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
Quoter
19
DSNParser
20
Daemon
21
Transformers
22
VersionCheck
23
HTTPMicro
24
Pingback
25
));
26
}
27
28
# ###########################################################################
29
# Percona::Toolkit package
30
# This package is a copy without comments from the original. The original
31
# with comments and its test file can be found in the Bazaar repository at,
32
# lib/Percona/Toolkit.pm
33
# t/lib/Percona/Toolkit.t
34
# See https://launchpad.net/percona-toolkit for more information.
35
# ###########################################################################
36
{
37
package Percona::Toolkit;
38
our $VERSION = '2.1.3';
39
1;
40
}
41
# ###########################################################################
42
# End Percona::Toolkit package
43
# ###########################################################################
10
44
11
45
# ###########################################################################
12
46
# OptionParser package
2064
2098
# ###########################################################################
2065
2099
2066
2100
# ###########################################################################
2101
# VersionCheck package
2102
# This package is a copy without comments from the original. The original
2103
# with comments and its test file can be found in the Bazaar repository at,
2104
# lib/VersionCheck.pm
2105
# t/lib/VersionCheck.t
2106
# See https://launchpad.net/percona-toolkit for more information.
2107
# ###########################################################################
2108
{
2109
package VersionCheck;
2110
2111
use strict;
2112
use warnings FATAL => 'all';
2113
use English qw(-no_match_vars);
2114
2115
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2116
2117
use File::Basename ();
2118
use Data::Dumper ();
2119
2120
sub Dumper {
2121
local $Data::Dumper::Indent = 1;
2122
local $Data::Dumper::Sortkeys = 1;
2123
local $Data::Dumper::Quotekeys = 0;
2124
2125
Data::Dumper::Dumper(@_);
2126
}
2127
2128
sub new {
2129
my ($class, %args) = @_;
2130
my $self = {
2131
valid_types => qr/
2132
^(?:
2133
os_version
2134
|perl_version
2135
|perl_module_version
2136
|mysql_variable
2137
|bin_version
2138
)$/x,
2139
};
2140
return bless $self, $class;
2141
}
2142
2143
sub parse_server_response {
2144
my ($self, %args) = @_;
2145
my @required_args = qw(response);
2146
foreach my $arg ( @required_args ) {
2147
die "I need a $arg arugment" unless $args{$arg};
2148
}
2149
my ($response) = @args{@required_args};
2150
2151
my %items = map {
2152
my ($item, $type, $vars) = split(";", $_);
2153
if ( !defined $args{split_vars} || $args{split_vars} ) {
2154
$vars = [ split(",", ($vars || '')) ];
2155
}
2156
$item => {
2157
item => $item,
2158
type => $type,
2159
vars => $vars,
2160
};
2161
} split("\n", $response);
2162
2163
PTDEBUG && _d('Items:', Dumper(\%items));
2164
2165
return \%items;
2166
}
2167
2168
sub get_versions {
2169
my ($self, %args) = @_;
2170
my @required_args = qw(items);
2171
foreach my $arg ( @required_args ) {
2172
die "I need a $arg arugment" unless $args{$arg};
2173
}
2174
my ($items) = @args{@required_args};
2175
my $dbh = $args{dbh}; # optional
2176
2177
my %versions;
2178
foreach my $item ( values %$items ) {
2179
next unless $self->valid_item($item);
2180
2181
eval {
2182
my $func = 'get_' . $item->{type};
2183
my $version = $self->$func(
2184
item => $item,
2185
dbh => $dbh,
2186
);
2187
if ( $version ) {
2188
chomp $version;
2189
$versions{$item->{item}} = $version;
2190
}
2191
};
2192
if ( $EVAL_ERROR ) {
2193
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
2194
}
2195
}
2196
2197
return \%versions;
2198
}
2199
2200
sub valid_item {
2201
my ($self, $item) = @_;
2202
return unless $item;
2203
2204
if ( ($item->{type} || '') !~ m/$self->{valid_types}/ ) {
2205
PTDEBUG && _d('Invalid type:', $item->{type});
2206
return;
2207
}
2208
2209
return 1;
2210
}
2211
2212
sub get_os_version {
2213
my ($self) = @_;
2214
2215
chomp(my $platform = `uname -s`);
2216
PTDEBUG && _d('platform:', $platform);
2217
return $OSNAME unless $platform;
2218
2219
chomp(my $lsb_release
2220
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
2221
PTDEBUG && _d('lsb_release:', $lsb_release);
2222
2223
my $release = "";
2224
2225
if ( $platform eq 'Linux' ) {
2226
if ( -f "/etc/fedora-release" ) {
2227
$release = `cat /etc/fedora-release`;
2228
}
2229
elsif ( -f "/etc/redhat-release" ) {
2230
$release = `cat /etc/redhat-release`;
2231
}
2232
elsif ( -f "/etc/system-release" ) {
2233
$release = `cat /etc/system-release`;
2234
}
2235
elsif ( $lsb_release ) {
2236
$release = `$lsb_release -ds`;
2237
}
2238
elsif ( -f "/etc/lsb-release" ) {
2239
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
2240
$release =~ s/^\w+="([^"]+)".+/$1/;
2241
}
2242
elsif ( -f "/etc/debian_version" ) {
2243
chomp(my $rel = `cat /etc/debian_version`);
2244
$release = "Debian $rel";
2245
if ( -f "/etc/apt/sources.list" ) {
2246
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}'`);
2247
$release .= " ($code_name)" if $code_name;
2248
}
2249
}
2250
elsif ( `ls /etc/*release 2>/dev/null` ) {
2251
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
2252
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
2253
}
2254
else {
2255
$release = `cat /etc/*release | head -n1`;
2256
}
2257
}
2258
}
2259
elsif ( $platform =~ m/^(BSD|Darwin)$/ ) {
2260
my $rel = `uname -r`;
2261
$release = "$platform $rel";
2262
}
2263
elsif ( $platform eq "SunOS" ) {
2264
my $rel = `head -n1 /etc/release` || `uname -r`;
2265
$release = "$platform $rel";
2266
}
2267
2268
if ( !$release ) {
2269
PTDEBUG && _d('Failed to get the release, using platform');
2270
$release = $platform;
2271
}
2272
chomp($release);
2273
2274
PTDEBUG && _d('OS version =', $release);
2275
return $release;
2276
}
2277
2278
sub get_perl_version {
2279
my ($self, %args) = @_;
2280
my $item = $args{item};
2281
return unless $item;
2282
2283
my $version = sprintf '%vd', $PERL_VERSION;
2284
PTDEBUG && _d('Perl version', $version);
2285
return $version;
2286
}
2287
2288
sub get_perl_module_version {
2289
my ($self, %args) = @_;
2290
my $item = $args{item};
2291
return unless $item;
2292
2293
my $var = $item->{item} . '::VERSION';
2294
my $version = _get_scalar($var);
2295
PTDEBUG && _d('Perl version for', $var, '=', "$version");
2296
2297
return $version ? "$version" : $version;
2298
}
2299
2300
sub _get_scalar {
2301
no strict;
2302
return ${*{shift()}};
2303
}
2304
2305
sub get_mysql_variable {
2306
my $self = shift;
2307
return $self->_get_from_mysql(
2308
show => 'VARIABLES',
2309
@_,
2310
);
2311
}
2312
2313
2314
sub _get_from_mysql {
2315
my ($self, %args) = @_;
2316
my $show = $args{show};
2317
my $item = $args{item};
2318
my $dbh = $args{dbh};
2319
return unless $show && $item && $dbh;
2320
2321
local $dbh->{FetchHashKeyName} = 'NAME_lc';
2322
my $sql = qq/SHOW $show/;
2323
PTDEBUG && _d($sql);
2324
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
2325
2326
my @versions;
2327
foreach my $var ( @{$item->{vars}} ) {
2328
$var = lc($var);
2329
my $version = $rows->{$var}->{value};
2330
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version);
2331
push @versions, $version;
2332
}
2333
2334
return join(' ', @versions);
2335
}
2336
2337
sub get_bin_version {
2338
my ($self, %args) = @_;
2339
my $item = $args{item};
2340
my $cmd = $item->{item};
2341
return unless $cmd;
2342
2343
my $sanitized_command = File::Basename::basename($cmd);
2344
PTDEBUG && _d('cmd:', $cmd, 'sanitized:', $sanitized_command);
2345
return if $sanitized_command !~ /\A[a-zA-Z0-9_-]+\z/;
2346
2347
my $output = `$sanitized_command --version 2>&1`;
2348
PTDEBUG && _d('output:', $output);
2349
2350
my ($version) = $output =~ /v?([0-9]+\.[0-9]+(?:\.[\w-]+)?)/;
2351
2352
PTDEBUG && _d('Version for', $sanitized_command, '=', $version);
2353
return $version;
2354
}
2355
2356
sub _d {
2357
my ($package, undef, $line) = caller 0;
2358
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2359
map { defined $_ ? $_ : 'undef' }
2360
@_;
2361
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2362
}
2363
2364
1;
2365
}
2366
# ###########################################################################
2367
# End VersionCheck package
2368
# ###########################################################################
2369
2370
# ###########################################################################
2371
# HTTPMicro package
2372
# This package is a copy without comments from the original. The original
2373
# with comments and its test file can be found in the Bazaar repository at,
2374
# lib/HTTPMicro.pm
2375
# t/lib/HTTPMicro.t
2376
# See https://launchpad.net/percona-toolkit for more information.
2377
# ###########################################################################
2378
{
2379
2380
package HTTPMicro;
2381
BEGIN {
2382
$HTTPMicro::VERSION = '0.001';
2383
}
2384
use strict;
2385
use warnings;
2386
2387
use Carp ();
2388
2389
2390
my @attributes;
2391
BEGIN {
2392
@attributes = qw(agent timeout);
2393
no strict 'refs';
2394
for my $accessor ( @attributes ) {
2395
*{$accessor} = sub {
2396
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
2397
};
2398
}
2399
}
2400
2401
sub new {
2402
my($class, %args) = @_;
2403
(my $agent = $class) =~ s{::}{-}g;
2404
my $self = {
2405
agent => $agent . "/" . ($class->VERSION || 0),
2406
timeout => 60,
2407
};
2408
for my $key ( @attributes ) {
2409
$self->{$key} = $args{$key} if exists $args{$key}
2410
}
2411
return bless $self, $class;
2412
}
2413
2414
sub request {
2415
my ($self, $method, $url, $args) = @_;
2416
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
2417
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
2418
$args ||= {}; # we keep some state in this during _request
2419
2420
my $response;
2421
for ( 0 .. 1 ) {
2422
$response = eval { $self->_request($method, $url, $args) };
2423
last unless $@ && $method eq 'GET'
2424
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
2425
}
2426
2427
if (my $e = "$@") {
2428
$response = {
2429
success => q{},
2430
status => 599,
2431
reason => 'Internal Exception',
2432
content => $e,
2433
headers => {
2434
'content-type' => 'text/plain',
2435
'content-length' => length $e,
2436
}
2437
};
2438
}
2439
return $response;
2440
}
2441
2442
sub _request {
2443
my ($self, $method, $url, $args) = @_;
2444
2445
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
2446
2447
my $request = {
2448
method => $method,
2449
scheme => $scheme,
2450
host_port => ($port == 80 ? $host : "$host:$port"),
2451
uri => $path_query,
2452
headers => {},
2453
};
2454
2455
my $handle = HTTPMicro::Handle->new(timeout => $self->{timeout});
2456
2457
$handle->connect($scheme, $host, $port);
2458
2459
$self->_prepare_headers_and_cb($request, $args);
2460
$handle->write_request_header(@{$request}{qw/method uri headers/});
2461
$handle->write_content_body($request) if $request->{content};
2462
2463
my $response;
2464
do { $response = $handle->read_response_header }
2465
until (substr($response->{status},0,1) ne '1');
2466
2467
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
2468
$response->{content} = '';
2469
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
2470
}
2471
2472
$handle->close;
2473
$response->{success} = substr($response->{status},0,1) eq '2';
2474
return $response;
2475
}
2476
2477
sub _prepare_headers_and_cb {
2478
my ($self, $request, $args) = @_;
2479
2480
for ($args->{headers}) {
2481
next unless defined;
2482
while (my ($k, $v) = each %$_) {
2483
$request->{headers}{lc $k} = $v;
2484
}
2485
}
2486
$request->{headers}{'host'} = $request->{host_port};
2487
$request->{headers}{'connection'} = "close";
2488
$request->{headers}{'user-agent'} ||= $self->{agent};
2489
2490
if (defined $args->{content}) {
2491
$request->{headers}{'content-type'} ||= "application/octet-stream";
2492
utf8::downgrade($args->{content}, 1)
2493
or Carp::croak(q/Wide character in request message body/);
2494
$request->{headers}{'content-length'} = length $args->{content};
2495
$request->{content} = $args->{content};
2496
}
2497
return;
2498
}
2499
2500
sub _split_url {
2501
my $url = pop;
2502
2503
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
2504
or Carp::croak(qq/Cannot parse URL: '$url'/);
2505
2506
$scheme = lc $scheme;
2507
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
2508
2509
my $host = (length($authority)) ? lc $authority : 'localhost';
2510
$host =~ s/\A[^@]*@//; # userinfo
2511
my $port = do {
2512
$host =~ s/:([0-9]*)\z// && length $1
2513
? $1
2514
: ($scheme eq 'http' ? 80 : undef);
2515
};
2516
2517
return ($scheme, $host, $port, $path_query);
2518
}
2519
2520
package
2521
HTTPMicro::Handle; # hide from PAUSE/indexers
2522
use strict;
2523
use warnings;
2524
2525
use Carp qw[croak];
2526
use Errno qw[EINTR EPIPE];
2527
use IO::Socket qw[SOCK_STREAM];
2528
2529
sub BUFSIZE () { 32768 }
2530
2531
my $Printable = sub {
2532
local $_ = shift;
2533
s/\r/\\r/g;
2534
s/\n/\\n/g;
2535
s/\t/\\t/g;
2536
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
2537
$_;
2538
};
2539
2540
sub new {
2541
my ($class, %args) = @_;
2542
return bless {
2543
rbuf => '',
2544
timeout => 60,
2545
max_line_size => 16384,
2546
%args
2547
}, $class;
2548
}
2549
2550
sub connect {
2551
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
2552
my ($self, $scheme, $host, $port) = @_;
2553
2554
if ( $scheme ne 'http' ) {
2555
croak(qq/Unsupported URL scheme '$scheme'/);
2556
}
2557
2558
$self->{fh} = 'IO::Socket::INET'->new(
2559
PeerHost => $host,
2560
PeerPort => $port,
2561
Proto => 'tcp',
2562
Type => SOCK_STREAM,
2563
Timeout => $self->{timeout}
2564
) or croak(qq/Could not connect to '$host:$port': $@/);
2565
2566
binmode($self->{fh})
2567
or croak(qq/Could not binmode() socket: '$!'/);
2568
2569
$self->{host} = $host;
2570
$self->{port} = $port;
2571
2572
return $self;
2573
}
2574
2575
sub close {
2576
@_ == 1 || croak(q/Usage: $handle->close()/);
2577
my ($self) = @_;
2578
CORE::close($self->{fh})
2579
or croak(qq/Could not close socket: '$!'/);
2580
}
2581
2582
sub write {
2583
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
2584
my ($self, $buf) = @_;
2585
2586
my $len = length $buf;
2587
my $off = 0;
2588
2589
local $SIG{PIPE} = 'IGNORE';
2590
2591
while () {
2592
$self->can_write
2593
or croak(q/Timed out while waiting for socket to become ready for writing/);
2594
my $r = syswrite($self->{fh}, $buf, $len, $off);
2595
if (defined $r) {
2596
$len -= $r;
2597
$off += $r;
2598
last unless $len > 0;
2599
}
2600
elsif ($! == EPIPE) {
2601
croak(qq/Socket closed by remote server: $!/);
2602
}
2603
elsif ($! != EINTR) {
2604
croak(qq/Could not write to socket: '$!'/);
2605
}
2606
}
2607
return $off;
2608
}
2609
2610
sub read {
2611
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
2612
my ($self, $len) = @_;
2613
2614
my $buf = '';
2615
my $got = length $self->{rbuf};
2616
2617
if ($got) {
2618
my $take = ($got < $len) ? $got : $len;
2619
$buf = substr($self->{rbuf}, 0, $take, '');
2620
$len -= $take;
2621
}
2622
2623
while ($len > 0) {
2624
$self->can_read
2625
or croak(q/Timed out while waiting for socket to become ready for reading/);
2626
my $r = sysread($self->{fh}, $buf, $len, length $buf);
2627
if (defined $r) {
2628
last unless $r;
2629
$len -= $r;
2630
}
2631
elsif ($! != EINTR) {
2632
croak(qq/Could not read from socket: '$!'/);
2633
}
2634
}
2635
if ($len) {
2636
croak(q/Unexpected end of stream/);
2637
}
2638
return $buf;
2639
}
2640
2641
sub readline {
2642
@_ == 1 || croak(q/Usage: $handle->readline()/);
2643
my ($self) = @_;
2644
2645
while () {
2646
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
2647
return $1;
2648
}
2649
$self->can_read
2650
or croak(q/Timed out while waiting for socket to become ready for reading/);
2651
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
2652
if (defined $r) {
2653
last unless $r;
2654
}
2655
elsif ($! != EINTR) {
2656
croak(qq/Could not read from socket: '$!'/);
2657
}
2658
}
2659
croak(q/Unexpected end of stream while looking for line/);
2660
}
2661
2662
sub read_header_lines {
2663
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
2664
my ($self, $headers) = @_;
2665
$headers ||= {};
2666
my $lines = 0;
2667
my $val;
2668
2669
while () {
2670
my $line = $self->readline;
2671
2672
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
2673
my ($field_name) = lc $1;
2674
$val = \($headers->{$field_name} = $2);
2675
}
2676
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
2677
$val
2678
or croak(q/Unexpected header continuation line/);
2679
next unless length $1;
2680
$$val .= ' ' if length $$val;
2681
$$val .= $1;
2682
}
2683
elsif ($line =~ /\A \x0D?\x0A \z/x) {
2684
last;
2685
}
2686
else {
2687
croak(q/Malformed header line: / . $Printable->($line));
2688
}
2689
}
2690
return $headers;
2691
}
2692
2693
sub write_header_lines {
2694
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
2695
my($self, $headers) = @_;
2696
2697
my $buf = '';
2698
while (my ($k, $v) = each %$headers) {
2699
my $field_name = lc $k;
2700
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
2701
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
2702
$field_name =~ s/\b(\w)/\u$1/g;
2703
$buf .= "$field_name: $v\x0D\x0A";
2704
}
2705
$buf .= "\x0D\x0A";
2706
return $self->write($buf);
2707
}
2708
2709
sub read_content_body {
2710
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
2711
my ($self, $cb, $response, $len) = @_;
2712
$len ||= $response->{headers}{'content-length'};
2713
2714
croak("No content-length in the returned response, and this "
2715
. "UA doesn't implement chunking") unless defined $len;
2716
2717
while ($len > 0) {
2718
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
2719
$cb->($self->read($read), $response);
2720
$len -= $read;
2721
}
2722
2723
return;
2724
}
2725
2726
sub write_content_body {
2727
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
2728
my ($self, $request) = @_;
2729
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
2730
2731
$len += $self->write($request->{content});
2732
2733
$len == $content_length
2734
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
2735
2736
return $len;
2737
}
2738
2739
sub read_response_header {
2740
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
2741
my ($self) = @_;
2742
2743
my $line = $self->readline;
2744
2745
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
2746
or croak(q/Malformed Status-Line: / . $Printable->($line));
2747
2748
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
2749
2750
return {
2751
status => $status,
2752
reason => $reason,
2753
headers => $self->read_header_lines,
2754
protocol => $protocol,
2755
};
2756
}
2757
2758
sub write_request_header {
2759
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
2760
my ($self, $method, $request_uri, $headers) = @_;
2761
2762
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
2763
+ $self->write_header_lines($headers);
2764
}
2765
2766
sub _do_timeout {
2767
my ($self, $type, $timeout) = @_;
2768
$timeout = $self->{timeout}
2769
unless defined $timeout && $timeout >= 0;
2770
2771
my $fd = fileno $self->{fh};
2772
defined $fd && $fd >= 0
2773
or croak(q/select(2): 'Bad file descriptor'/);
2774
2775
my $initial = time;
2776
my $pending = $timeout;
2777
my $nfound;
2778
2779
vec(my $fdset = '', $fd, 1) = 1;
2780
2781
while () {
2782
$nfound = ($type eq 'read')
2783
? select($fdset, undef, undef, $pending)
2784
: select(undef, $fdset, undef, $pending) ;
2785
if ($nfound == -1) {
2786
$! == EINTR
2787
or croak(qq/select(2): '$!'/);
2788
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
2789
$nfound = 0;
2790
}
2791
last;
2792
}
2793
$! = 0;
2794
return $nfound;
2795
}
2796
2797
sub can_read {
2798
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
2799
my $self = shift;
2800
return $self->_do_timeout('read', @_)
2801
}
2802
2803
sub can_write {
2804
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
2805
my $self = shift;
2806
return $self->_do_timeout('write', @_)
2807
}
2808
2809
1;
2810
}
2811
# ###########################################################################
2812
# End HTTPMicro package
2813
# ###########################################################################
2814
2815
# ###########################################################################
2816
# Pingback package
2817
# This package is a copy without comments from the original. The original
2818
# with comments and its test file can be found in the Bazaar repository at,
2819
# lib/Pingback.pm
2820
# t/lib/Pingback.t
2821
# See https://launchpad.net/percona-toolkit for more information.
2822
# ###########################################################################
2823
{
2824
package Pingback;
2825
2826
use strict;
2827
use warnings FATAL => 'all';
2828
use English qw(-no_match_vars);
2829
2830
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2831
2832
use File::Basename qw();
2833
use Data::Dumper qw();
2834
use Fcntl qw(:DEFAULT);
2835
2836
use File::Spec;
2837
2838
my $dir = File::Spec->tmpdir();
2839
my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check');
2840
my $check_time_limit = 60 * 60 * 24; # one day
2841
2842
sub Dumper {
2843
local $Data::Dumper::Indent = 1;
2844
local $Data::Dumper::Sortkeys = 1;
2845
local $Data::Dumper::Quotekeys = 0;
2846
2847
Data::Dumper::Dumper(@_);
2848
}
2849
2850
local $EVAL_ERROR;
2851
eval {
2852
require HTTPMicro;
2853
require VersionCheck;
2854
};
2855
2856
sub version_check {
2857
eval {
2858
if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) {
2859
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
2860
_d('--version-check is disabled by the PERCONA_VERSION_CHECK',
2861
'environment variable');
2862
}
2863
return;
2864
}
2865
2866
if ( !time_to_check($check_time_file) ) {
2867
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
2868
_d('It is not time to --version-checka again;',
2869
'only 1 check per', $check_time_limit, 'seconds, and the last',
2870
'check was performed on the modified time of', $check_time_file);
2871
}
2872
return;
2873
}
2874
2875
my $dbh = shift; # optional
2876
my $advice = pingback(
2877
url => $ENV{PERCONA_VERSION_CHECK_URL} || 'http://v.percona.com',
2878
dbh => $dbh,
2879
);
2880
if ( $advice ) {
2881
print "# Percona suggests these upgrades:\n";
2882
print join("\n", map { "# * $_" } @$advice);
2883
print "\n# Specify --no-version-check to disable these suggestions.\n\n";
2884
}
2885
elsif ( $ENV{PTVCDEBUG} || PTDEBUG ) {
2886
_d('--version-check worked, but there were no suggestions');
2887
}
2888
};
2889
if ( $EVAL_ERROR ) {
2890
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
2891
_d('Error doing --version-check:', $EVAL_ERROR);
2892
}
2893
}
2894
2895
return;
2896
}
2897
2898
sub pingback {
2899
my (%args) = @_;
2900
my @required_args = qw(url);
2901
foreach my $arg ( @required_args ) {
2902
die "I need a $arg arugment" unless $args{$arg};
2903
}
2904
my ($url) = @args{@required_args};
2905
2906
my ($dbh, $ua, $vc) = @args{qw(dbh ua VersionCheck)};
2907
2908
$ua ||= HTTPMicro->new( timeout => 2 );
2909
$vc ||= VersionCheck->new();
2910
2911
my $response = $ua->request('GET', $url);
2912
PTDEBUG && _d('Server response:', Dumper($response));
2913
die "No response from GET $url"
2914
if !$response;
2915
die "GET $url returned HTTP status $response->{status}; expected 200"
2916
if $response->{status} != 200;
2917
die "GET $url did not return any programs to check"
2918
if !$response->{content};
2919
2920
my $items = $vc->parse_server_response(
2921
response => $response->{content}
2922
);
2923
die "Failed to parse server requested programs: $response->{content}"
2924
if !scalar keys %$items;
2925
2926
my $versions = $vc->get_versions(
2927
items => $items,
2928
dbh => $dbh,
2929
);
2930
die "Failed to get any program versions; should have at least gotten Perl"
2931
if !scalar keys %$versions;
2932
2933
my $client_content = encode_client_response(
2934
items => $items,
2935
versions => $versions,
2936
);
2937
2938
my $client_response = {
2939
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
2940
content => $client_content,
2941
};
2942
PTDEBUG && _d('Client response:', Dumper($client_response));
2943
2944
$response = $ua->request('POST', $url, $client_response);
2945
PTDEBUG && _d('Server suggestions:', Dumper($response));
2946
die "No response from POST $url $client_response"
2947
if !$response;
2948
die "POST $url returned HTTP status $response->{status}; expected 200"
2949
if $response->{status} != 200;
2950
2951
return unless $response->{content};
2952
2953
$items = $vc->parse_server_response(
2954
response => $response->{content},
2955
split_vars => 0,
2956
);
2957
die "Failed to parse server suggestions: $response->{content}"
2958
if !scalar keys %$items;
2959
my @suggestions = map { $_->{vars} }
2960
sort { $a->{item} cmp $b->{item} }
2961
values %$items;
2962
2963
return \@suggestions;
2964
}
2965
2966
sub time_to_check {
2967
my ($file) = @_;
2968
die "I need a file argument" unless $file;
2969
2970
if ( !-f $file ) {
2971
PTDEBUG && _d('Creating', $file);
2972
_touch($file);
2973
return 1;
2974
}
2975
2976
my $mtime = (stat $file)[9];
2977
if ( !defined $mtime ) {
2978
PTDEBUG && _d('Error getting modified time of', $file);
2979
return 0;
2980
}
2981
2982
my $time = int(time());
2983
PTDEBUG && _d('time=', $time, 'mtime=', $mtime);
2984
if ( ($time - $mtime) > $check_time_limit ) {
2985
_touch($file);
2986
return 1;
2987
}
2988
2989
return 0;
2990
}
2991
2992
sub _touch {
2993
my ($file) = @_;
2994
sysopen my $fh, $file, O_WRONLY|O_CREAT|O_NONBLOCK
2995
or die "Cannot create $file : $!";
2996
close $fh or die "Cannot close $file : $!";
2997
utime(undef, undef, $file);
2998
}
2999
3000
sub encode_client_response {
3001
my (%args) = @_;
3002
my @required_args = qw(items versions);
3003
foreach my $arg ( @required_args ) {
3004
die "I need a $arg arugment" unless $args{$arg};
3005
}
3006
my ($items, $versions) = @args{@required_args};
3007
3008
my @lines;
3009
foreach my $item ( sort keys %$items ) {
3010
next unless exists $versions->{$item};
3011
push @lines, join(';', $item, $versions->{$item});
3012
}
3013
3014
my $client_response = join("\n", @lines) . "\n";
3015
PTDEBUG && _d('Client response:', $client_response);
3016
return $client_response;
3017
}
3018
3019
sub _d {
3020
my ($package, undef, $line) = caller 0;
3021
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3022
map { defined $_ ? $_ : 'undef' }
3023
@_;
3024
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3025
}
3026
3027
1;
3028
}
3029
# ###########################################################################
3030
# End Pingback package
3031
# ###########################################################################
3032
3033
# ###########################################################################
2067
3034
# This is a combination of modules and programs in one -- a runnable module.
2068
3035
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
2069
3036
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
2073
3040
# ###########################################################################
2074
3041
package pt_fk_error_logger;
2075
3042
3043
use strict;
3044
use warnings FATAL => 'all';
2076
3045
use English qw(-no_match_vars);
2077
3046
use sigtrap qw(handler finish untrapped normal-signals);
2078
3047
3048
use Percona::Toolkit;
2079
3049
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
2080
3050
2081
3051
Transformers->import(qw(parse_timestamp));
2083
3053
my $oktorun;
2084
3054
2085
3055
sub main {
2086
@ARGV = @_; # set global ARGV for this package
3056
local @ARGV = @_; # set global ARGV for this package
3057
$oktorun = 1;
2087
3058
2088
3059
# ########################################################################
2089
3060
# Get configuration information.
2159
3130
$ins_sth = $dst_dbh->prepare($sql);
2160
3131
}
2161
3132
3133
# ########################################################################
2162
3134
# Daemonize only after (potentially) asking for passwords for --ask-pass.
3135
# ########################################################################
2163
3136
my $daemon;
2164
3137
if ( $o->get('daemonize') ) {
2165
3138
$daemon = new Daemon(o=>$o);
2172
3145
$daemon->make_PID_file();
2173
3146
}
2174
3147
2175
$oktorun = 1;
3148
# ########################################################################
3149
# Do the version-check
3150
# ########################################################################
3151
if ( $o->get('version-check') && ($o->has('quiet') && !$o->get('quiet')) ) {
3152
Pingback::version_check($dbh);
3153
}
3154
3155
# ########################################################################
3156
# Start finding and logging foreign key errors.
3157
# ########################################################################
2176
3158
while ( # Quit if:
2177
3159
($start == $end || $now < $end) # time is exceeded
2178
3160
&& $oktorun # or instructed to quit
2454
3436
2455
3437
Show version and exit.
2456
3438
3439
=item --[no]version-check
3440
3441
default: yes
3442
3443
Send program versions to Percona and print suggested upgrades and problems.
3444
3445
The version check feature causes the tool to send and receive data from
3446
Percona over the web. The data contains program versions from the local
3447
machine. Percona uses the data to focus development on the most widely
3448
used versions of programs, and to suggest to customers possible upgrades
3449
and known bad versions of programs.
3450
3451
This feature can be disabled by specifying C<--no-version-check> on the
3452
command line or in one of several L<"--config"> files, or by setting the
3453
environment variable C<PERCONA_VERSION_CHECK=0>.
3454
3455
For more information, visit L<http://www.percona.com/version-check>.
3456
2457
3457
=back
2458
3458
2459
3459
=head1 DSN OPTIONS
Loggerhead is a web-based interface for Breezy
Version: 2.0.1