« back to all changes in this revision
Viewing changes to bin/pt-query-digest
- browse files at revision 530
- compare with another revision
- download diff
- download tarball
- view history from revision 530
- Committer: Brian Fraser
- Date: 2013-02-25 15:13:35 UTC
- Revision ID: fraserbn@gmail.com-20130225151335-3z7wkeviyzci7ojm
pqd: Remove --type pglog, memcached, and http
- files removed:
- lib/HTTPProtocolParser.pm
- t/lib/samples/http
- t/lib/samples/memcached
- t/lib/samples/pg
- files modified:
- bin/pt-query-digest
added
removed
bin/pt-query-digest
27
27
Processlist
28
28
TcpdumpParser
29
29
MySQLProtocolParser
30
SysLogParser
31
PgLogParser
32
30
SlowLogParser
33
31
SlowLogWriter
34
32
EventAggregator
40
38
TableParser
41
39
QueryReview
42
40
Daemon
43
MemcachedProtocolParser
44
MemcachedEvent
45
41
BinaryLogParser
46
42
GeneralLogParser
47
43
RawLogParser
48
44
ProtocolParser
49
HTTPProtocolParser
50
45
MasterSlave
51
46
Progress
52
47
FileIterator
3493
3488
sub port_number {
3494
3489
my ( $self, $port ) = @_;
3495
3490
return unless $port;
3496
return $port eq 'memcached' ? 11211
3497
: $port eq 'http' ? 80
3498
: $port eq 'mysql' ? 3306
3499
: $port;
3491
return $port eq 'mysql' ? 3306 : $port;
3500
3492
}
3501
3493
3502
3494
sub _d {
4825
4817
# ###########################################################################
4826
4818
4827
4819
# ###########################################################################
4828
# SysLogParser package
4829
# This package is a copy without comments from the original. The original
4830
# with comments and its test file can be found in the Bazaar repository at,
4831
# lib/SysLogParser.pm
4832
# t/lib/SysLogParser.t
4833
# See https://launchpad.net/percona-toolkit for more information.
4834
# ###########################################################################
4835
{
4836
package SysLogParser;
4837
4838
use strict;
4839
use warnings FATAL => 'all';
4840
use English qw(-no_match_vars);
4841
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4842
4843
my $syslog_regex = qr{\A.*\w+\[\d+\]: \[(\d+)-(\d+)\] (.*)\Z};
4844
4845
sub new {
4846
my ( $class ) = @_;
4847
my $self = {};
4848
return bless $self, $class;
4849
}
4850
4851
sub parse_event {
4852
my ( $self, %args ) = @_;
4853
my ( $next_event, $tell, $is_syslog ) = $self->generate_wrappers(%args);
4854
return $next_event->();
4855
}
4856
4857
sub generate_wrappers {
4858
my ( $self, %args ) = @_;
4859
4860
if ( ($self->{sanity} || '') ne "$args{next_event}" ){
4861
PTDEBUG && _d("Clearing and recreating internal state");
4862
@{$self}{qw(next_event tell is_syslog)} = $self->make_closures(%args);
4863
$self->{sanity} = "$args{next_event}";
4864
}
4865
4866
return @{$self}{qw(next_event tell is_syslog)};
4867
}
4868
4869
sub make_closures {
4870
my ( $self, %args ) = @_;
4871
4872
my $next_event = $args{'next_event'};
4873
my $tell = $args{'tell'};
4874
my $new_event_test = $args{'misc'}->{'new_event_test'};
4875
my $line_filter = $args{'misc'}->{'line_filter'};
4876
4877
my $test_line = $next_event->();
4878
PTDEBUG && _d('Read first sample/test line:', $test_line);
4879
4880
if ( defined $test_line && $test_line =~ m/$syslog_regex/o ) {
4881
4882
PTDEBUG && _d('This looks like a syslog line, PTDEBUG prefix=LLSP');
4883
4884
my ($msg_nr, $line_nr, $content) = $test_line =~ m/$syslog_regex/o;
4885
my @pending = ($test_line);
4886
my $last_msg_nr = $msg_nr;
4887
my $pos_in_log = 0;
4888
4889
my $new_next_event = sub {
4890
PTDEBUG && _d('LLSP: next_event()');
4891
4892
PTDEBUG && _d('LLSP: Current virtual $fh position:', $pos_in_log);
4893
my $new_pos = 0;
4894
4895
my @arg_lines;
4896
4897
my $line;
4898
LINE:
4899
while (
4900
defined($line = shift @pending)
4901
|| do {
4902
eval { $new_pos = -1; $new_pos = $tell->() };
4903
defined($line = $next_event->());
4904
}
4905
) {
4906
PTDEBUG && _d('LLSP: Line:', $line);
4907
4908
($msg_nr, $line_nr, $content) = $line =~ m/$syslog_regex/o;
4909
if ( !$msg_nr ) {
4910
die "Can't parse line: $line";
4911
}
4912
4913
elsif ( $msg_nr != $last_msg_nr ) {
4914
PTDEBUG && _d('LLSP: $msg_nr', $last_msg_nr, '=>', $msg_nr);
4915
$last_msg_nr = $msg_nr;
4916
last LINE;
4917
}
4918
4919
elsif ( @arg_lines && $new_event_test && $new_event_test->($content) ) {
4920
PTDEBUG && _d('LLSP: $new_event_test matches');
4921
last LINE;
4922
}
4923
4924
$content =~ s/#(\d{3})/chr(oct($1))/ge;
4925
$content =~ s/\^I/\t/g;
4926
if ( $line_filter ) {
4927
PTDEBUG && _d('LLSP: applying $line_filter');
4928
$content = $line_filter->($content);
4929
}
4930
4931
push @arg_lines, $content;
4932
}
4933
PTDEBUG && _d('LLSP: Exited while-loop after finding a complete entry');
4934
4935
my $psql_log_event = @arg_lines ? join('', @arg_lines) : undef;
4936
PTDEBUG && _d('LLSP: Final log entry:', $psql_log_event);
4937
4938
if ( defined $line ) {
4939
PTDEBUG && _d('LLSP: Saving $line:', $line);
4940
@pending = $line;
4941
PTDEBUG && _d('LLSP: $pos_in_log:', $pos_in_log, '=>', $new_pos);
4942
$pos_in_log = $new_pos;
4943
}
4944
else {
4945
PTDEBUG && _d('LLSP: EOF reached');
4946
@pending = ();
4947
$last_msg_nr = 0;
4948
}
4949
4950
return $psql_log_event;
4951
};
4952
4953
my $new_tell = sub {
4954
PTDEBUG && _d('LLSP: tell()', $pos_in_log);
4955
return $pos_in_log;
4956
};
4957
4958
return ($new_next_event, $new_tell, 1);
4959
}
4960
4961
else {
4962
4963
PTDEBUG && _d('Plain log, or we are at EOF; PTDEBUG prefix=PLAIN');
4964
4965
my @pending = defined $test_line ? ($test_line) : ();
4966
4967
my $new_next_event = sub {
4968
PTDEBUG && _d('PLAIN: next_event(); @pending:', scalar @pending);
4969
return @pending ? shift @pending : $next_event->();
4970
};
4971
my $new_tell = sub {
4972
PTDEBUG && _d('PLAIN: tell(); @pending:', scalar @pending);
4973
return @pending ? 0 : $tell->();
4974
};
4975
return ($new_next_event, $new_tell, 0);
4976
}
4977
}
4978
4979
sub _d {
4980
my ($package, undef, $line) = caller 0;
4981
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4982
map { defined $_ ? $_ : 'undef' }
4983
@_;
4984
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4985
}
4986
4987
1;
4988
}
4989
# ###########################################################################
4990
# End SysLogParser package
4991
# ###########################################################################
4992
4993
# ###########################################################################
4994
# PgLogParser package
4995
# This package is a copy without comments from the original. The original
4996
# with comments and its test file can be found in the Bazaar repository at,
4997
# lib/PgLogParser.pm
4998
# t/lib/PgLogParser.t
4999
# See https://launchpad.net/percona-toolkit for more information.
5000
# ###########################################################################
5001
{
5002
package PgLogParser;
5003
5004
use strict;
5005
use warnings FATAL => 'all';
5006
use English qw(-no_match_vars);
5007
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
5008
5009
use Data::Dumper;
5010
$Data::Dumper::Indent = 1;
5011
$Data::Dumper::Sortkeys = 1;
5012
$Data::Dumper::Quotekeys = 0;
5013
5014
my $log_line_regex = qr{
5015
(LOG|DEBUG|CONTEXT|WARNING|ERROR|FATAL|PANIC|HINT
5016
|DETAIL|NOTICE|STATEMENT|INFO|LOCATION)
5017
:\s\s+
5018
}x;
5019
5020
my %attrib_name_for = (
5021
u => 'user',
5022
d => 'db',
5023
r => 'host', # With port
5024
h => 'host',
5025
p => 'Process_id',
5026
t => 'ts',
5027
m => 'ts', # With milliseconds
5028
i => 'Query_type',
5029
c => 'Session_id',
5030
l => 'Line_no',
5031
s => 'Session_id',
5032
v => 'Vrt_trx_id',
5033
x => 'Trx_id',
5034
);
5035
5036
sub new {
5037
my ( $class ) = @_;
5038
my $self = {
5039
pending => [],
5040
is_syslog => undef,
5041
next_event => undef,
5042
'tell' => undef,
5043
};
5044
return bless $self, $class;
5045
}
5046
5047
sub parse_event {
5048
my ( $self, %args ) = @_;
5049
my @required_args = qw(next_event tell);
5050
foreach my $arg ( @required_args ) {
5051
die "I need a $arg argument" unless $args{$arg};
5052
}
5053
5054
my ( $next_event, $tell, $is_syslog ) = $self->generate_wrappers(%args);
5055
5056
my @properties = ();
5057
5058
my ($pos_in_log, $line, $was_pending) = $self->get_line();
5059
my $new_pos;
5060
5061
my @arg_lines;
5062
5063
my $done;
5064
5065
my $got_duration;
5066
5067
if ( !$was_pending && (!defined $line || $line !~ m/$log_line_regex/o) ) {
5068
PTDEBUG && _d('Skipping lines until I find a header');
5069
my $found_header;
5070
LINE:
5071
while (
5072
eval {
5073
($new_pos, $line) = $self->get_line();
5074
defined $line;
5075
}
5076
) {
5077
if ( $line =~ m/$log_line_regex/o ) {
5078
$pos_in_log = $new_pos;
5079
last LINE;
5080
}
5081
else {
5082
PTDEBUG && _d('Line was not a header, will fetch another');
5083
}
5084
}
5085
PTDEBUG && _d('Found a header line, now at pos_in_line', $pos_in_log);
5086
}
5087
5088
my $first_line;
5089
5090
my $line_type;
5091
5092
LINE:
5093
while ( !$done && defined $line ) {
5094
5095
chomp $line unless $is_syslog;
5096
5097
if ( (($line_type) = $line =~ m/$log_line_regex/o) && $line_type ne 'LOG' ) {
5098
5099
if ( @arg_lines ) {
5100
PTDEBUG && _d('Found a non-LOG line, exiting loop');
5101
last LINE;
5102
}
5103
5104
else {
5105
$first_line ||= $line;
5106
5107
if ( my ($e) = $line =~ m/ERROR:\s+(\S.*)\Z/s ) {
5108
push @properties, 'Error_msg', $e;
5109
PTDEBUG && _d('Found an error msg, saving and continuing');
5110
($new_pos, $line) = $self->get_line();
5111
next LINE;
5112
}
5113
5114
elsif ( my ($s) = $line =~ m/STATEMENT:\s+(\S.*)\Z/s ) {
5115
push @properties, 'arg', $s, 'cmd', 'Query';
5116
PTDEBUG && _d('Found a statement, finishing up event');
5117
$done = 1;
5118
last LINE;
5119
}
5120
5121
else {
5122
PTDEBUG && _d("I don't know what to do with this line");
5123
}
5124
}
5125
5126
}
5127
5128
if (
5129
$line =~ m{
5130
Address\sfamily\snot\ssupported\sby\sprotocol
5131
|archived\stransaction\slog\sfile
5132
|autovacuum:\sprocessing\sdatabase
5133
|checkpoint\srecord\sis\sat
5134
|checkpoints\sare\soccurring\stoo\sfrequently\s\(
5135
|could\snot\sreceive\sdata\sfrom\sclient
5136
|database\ssystem\sis\sready
5137
|database\ssystem\sis\sshut\sdown
5138
|database\ssystem\swas\sshut\sdown
5139
|incomplete\sstartup\spacket
5140
|invalid\slength\sof\sstartup\spacket
5141
|next\sMultiXactId:
5142
|next\stransaction\sID:
5143
|received\ssmart\sshutdown\srequest
5144
|recycled\stransaction\slog\sfile
5145
|redo\srecord\sis\sat
5146
|removing\sfile\s"
5147
|removing\stransaction\slog\sfile\s"
5148
|shutting\sdown
5149
|transaction\sID\swrap\slimit\sis
5150
}x
5151
) {
5152
PTDEBUG && _d('Skipping this line because it matches skip-pattern');
5153
($new_pos, $line) = $self->get_line();
5154
next LINE;
5155
}
5156
5157
$first_line ||= $line;
5158
5159
if ( $line !~ m/$log_line_regex/o && @arg_lines ) {
5160
5161
if ( !$is_syslog ) {
5162
$line =~ s/\A\t?/\n/;
5163
}
5164
5165
push @arg_lines, $line;
5166
PTDEBUG && _d('This was a continuation line');
5167
}
5168
5169
elsif (
5170
my ( $sev, $label, $rest )
5171
= $line =~ m/$log_line_regex(.+?):\s+(.*)\Z/so
5172
) {
5173
PTDEBUG && _d('Line is case 1 or case 3');
5174
5175
if ( @arg_lines ) {
5176
$done = 1;
5177
PTDEBUG && _d('There are saved @arg_lines, we are done');
5178
5179
if ( $label eq 'duration' && $rest =~ m/[0-9.]+\s+\S+\Z/ ) {
5180
if ( $got_duration ) {
5181
PTDEBUG && _d('Discarding line, duration already found');
5182
}
5183
else {
5184
push @properties, 'Query_time', $self->duration_to_secs($rest);
5185
PTDEBUG && _d("Line's duration is for previous event:", $rest);
5186
}
5187
}
5188
else {
5189
$self->pending($new_pos, $line);
5190
PTDEBUG && _d('Deferred line');
5191
}
5192
}
5193
5194
elsif ( $label =~ m/\A(?:duration|statement|query)\Z/ ) {
5195
PTDEBUG && _d('Case 1: start a multi-line event');
5196
5197
if ( $label eq 'duration' ) {
5198
5199
if (
5200
(my ($dur, $stmt)
5201
= $rest =~ m/([0-9.]+ \S+)\s+(?:statement|query): *(.*)\Z/s)
5202
) {
5203
push @properties, 'Query_time', $self->duration_to_secs($dur);
5204
$got_duration = 1;
5205
push @arg_lines, $stmt;
5206
PTDEBUG && _d('Duration + statement');
5207
}
5208
5209
else {
5210
$first_line = undef;
5211
($pos_in_log, $line) = $self->get_line();
5212
PTDEBUG && _d('Line applies to event we never saw, discarding');
5213
next LINE;
5214
}
5215
}
5216
else {
5217
push @arg_lines, $rest;
5218
PTDEBUG && _d('Putting onto @arg_lines');
5219
}
5220
}
5221
5222
else {
5223
$done = 1;
5224
PTDEBUG && _d('Line is case 3, event is done');
5225
5226
if ( @arg_lines ) {
5227
$self->pending($new_pos, $line);
5228
PTDEBUG && _d('There was @arg_lines, putting line to pending');
5229
}
5230
5231
else {
5232
PTDEBUG && _d('No need to defer, process event from this line now');
5233
push @properties, 'cmd', 'Admin', 'arg', $label;
5234
5235
if ( $label =~ m/\A(?:dis)?connection(?: received| authorized)?\Z/ ) {
5236
push @properties, $self->get_meta($rest);
5237
}
5238
5239
else {
5240
die "I don't understand line $line";
5241
}
5242
5243
}
5244
}
5245
5246
}
5247
5248
else {
5249
die "I don't understand line $line";
5250
}
5251
5252
if ( !$done ) {
5253
($new_pos, $line) = $self->get_line();
5254
}
5255
} # LINE
5256
5257
if ( !defined $line ) {
5258
PTDEBUG && _d('Line not defined, at EOF; calling oktorun(0) if exists');
5259
$args{oktorun}->(0) if $args{oktorun};
5260
if ( !@arg_lines ) {
5261
PTDEBUG && _d('No saved @arg_lines either, we are all done');
5262
return undef;
5263
}
5264
}
5265
5266
if ( $line_type && $line_type ne 'LOG' ) {
5267
PTDEBUG && _d('Line is not a LOG line');
5268
5269
if ( $line_type eq 'ERROR' ) {
5270
PTDEBUG && _d('Line is ERROR');
5271
5272
if ( @arg_lines ) {
5273
PTDEBUG && _d('There is @arg_lines, will peek ahead one line');
5274
my ( $temp_pos, $temp_line ) = $self->get_line();
5275
my ( $type, $msg );
5276
if (
5277
defined $temp_line
5278
&& ( ($type, $msg) = $temp_line =~ m/$log_line_regex(.*)/o )
5279
&& ( $type ne 'STATEMENT' || $msg eq $arg_lines[-1] )
5280
) {
5281
PTDEBUG && _d('Error/statement line pertain to current event');
5282
push @properties, 'Error_msg', $line =~ m/ERROR:\s*(\S.*)\Z/s;
5283
if ( $type ne 'STATEMENT' ) {
5284
PTDEBUG && _d('Must save peeked line, it is a', $type);
5285
$self->pending($temp_pos, $temp_line);
5286
}
5287
}
5288
elsif ( defined $temp_line && defined $type ) {
5289
PTDEBUG && _d('Error/statement line are a new event');
5290
$self->pending($new_pos, $line);
5291
$self->pending($temp_pos, $temp_line);
5292
}
5293
else {
5294
PTDEBUG && _d("Unknown line", $line);
5295
}
5296
}
5297
}
5298
else {
5299
PTDEBUG && _d("Unknown line", $line);
5300
}
5301
}
5302
5303
if ( $done || @arg_lines ) {
5304
PTDEBUG && _d('Making event');
5305
5306
push @properties, 'pos_in_log', $pos_in_log;
5307
5308
if ( @arg_lines ) {
5309
PTDEBUG && _d('Assembling @arg_lines: ', scalar @arg_lines);
5310
push @properties, 'arg', join('', @arg_lines), 'cmd', 'Query';
5311
}
5312
5313
if ( $first_line ) {
5314
if ( my ($ts) = $first_line =~ m/([0-9-]{10} [0-9:.]{8,12})/ ) {
5315
PTDEBUG && _d('Getting timestamp', $ts);
5316
push @properties, 'ts', $ts;
5317
}
5318
5319
if ( my ($meta) = $first_line =~ m/(.*?)[A-Z]{3,}: / ) {
5320
PTDEBUG && _d('Found a meta-data chunk:', $meta);
5321
push @properties, $self->get_meta($meta);
5322
}
5323
}
5324
5325
PTDEBUG && _d('Properties of event:', Dumper(\@properties));
5326
my $event = { @properties };
5327
$event->{bytes} = length($event->{arg} || '');
5328
return $event;
5329
}
5330
5331
}
5332
5333
sub get_meta {
5334
my ( $self, $meta ) = @_;
5335
my @properties;
5336
foreach my $set ( $meta =~ m/(\w+=[^, ]+)/g ) {
5337
my ($key, $val) = split(/=/, $set);
5338
if ( $key && $val ) {
5339
if ( my $prop = $attrib_name_for{lc substr($key, 0, 1)} ) {
5340
push @properties, $prop, $val;
5341
}
5342
else {
5343
PTDEBUG && _d('Bad meta key', $set);
5344
}
5345
}
5346
else {
5347
PTDEBUG && _d("Can't figure out meta from", $set);
5348
}
5349
}
5350
return @properties;
5351
}
5352
5353
sub get_line {
5354
my ( $self ) = @_;
5355
my ($pos, $line, $was_pending) = $self->pending;
5356
if ( ! defined $line ) {
5357
PTDEBUG && _d('Got nothing from pending, trying the $fh');
5358
my ( $next_event, $tell) = @{$self}{qw(next_event tell)};
5359
eval {
5360
$pos = $tell->();
5361
$line = $next_event->();
5362
};
5363
if ( PTDEBUG && $EVAL_ERROR ) {
5364
_d($EVAL_ERROR);
5365
}
5366
}
5367
5368
PTDEBUG && _d('Got pos/line:', $pos, $line);
5369
return ($pos, $line);
5370
}
5371
5372
sub pending {
5373
my ( $self, $val, $pos_in_log ) = @_;
5374
my $was_pending;
5375
PTDEBUG && _d('In sub pending, val:', $val);
5376
if ( $val ) {
5377
push @{$self->{pending}}, [$val, $pos_in_log];
5378
}
5379
elsif ( @{$self->{pending}} ) {
5380
($val, $pos_in_log) = @{ shift @{$self->{pending}} };
5381
$was_pending = 1;
5382
}
5383
PTDEBUG && _d('Return from pending:', $val, $pos_in_log);
5384
return ($val, $pos_in_log, $was_pending);
5385
}
5386
5387
sub generate_wrappers {
5388
my ( $self, %args ) = @_;
5389
5390
if ( ($self->{sanity} || '') ne "$args{next_event}" ){
5391
PTDEBUG && _d("Clearing and recreating internal state");
5392
eval { require SysLogParser; }; # Required for tests to work.
5393
my $sl = new SysLogParser();
5394
5395
$args{misc}->{new_event_test} = sub {
5396
my ( $content ) = @_;
5397
return unless defined $content;
5398
return $content =~ m/$log_line_regex/o;
5399
};
5400
5401
$args{misc}->{line_filter} = sub {
5402
my ( $content ) = @_;
5403
$content =~ s/\A\t/\n/;
5404
return $content;
5405
};
5406
5407
@{$self}{qw(next_event tell is_syslog)} = $sl->make_closures(%args);
5408
$self->{sanity} = "$args{next_event}";
5409
}
5410
5411
return @{$self}{qw(next_event tell is_syslog)};
5412
}
5413
5414
sub duration_to_secs {
5415
my ( $self, $str ) = @_;
5416
PTDEBUG && _d('Duration:', $str);
5417
my ( $num, $suf ) = split(/\s+/, $str);
5418
my $factor = $suf eq 'ms' ? 1000
5419
: $suf eq 'sec' ? 1
5420
: die("Unknown suffix '$suf'");
5421
return $num / $factor;
5422
}
5423
5424
sub _d {
5425
my ($package, undef, $line) = caller 0;
5426
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
5427
map { defined $_ ? $_ : 'undef' }
5428
@_;
5429
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
5430
}
5431
5432
1;
5433
}
5434
# ###########################################################################
5435
# End PgLogParser package
5436
# ###########################################################################
5437
5438
# ###########################################################################
5439
4820
# SlowLogParser package
5440
4821
# This package is a copy without comments from the original. The original
5441
4822
# with comments and its test file can be found in the Bazaar repository at,
7436
6817
}
7437
6818
7438
6819
my $log_type = $args{log_type} || '';
7439
my $mark = $log_type eq 'memcached'
7440
|| $log_type eq 'http'
7441
|| $log_type eq 'pglog' ? '' : '\G';
6820
my $mark = '\G';
7442
6821
7443
6822
if ( $item =~ m/^(?:[\(\s]*select|insert|replace)/ ) {
7444
6823
if ( $item =~ m/^(?:insert|replace)/ ) { # No EXPLAIN
9694
9073
# ###########################################################################
9695
9074
9696
9075
# ###########################################################################
9697
# MemcachedProtocolParser package
9698
# This package is a copy without comments from the original. The original
9699
# with comments and its test file can be found in the Bazaar repository at,
9700
# lib/MemcachedProtocolParser.pm
9701
# t/lib/MemcachedProtocolParser.t
9702
# See https://launchpad.net/percona-toolkit for more information.
9703
# ###########################################################################
9704
{
9705
package MemcachedProtocolParser;
9706
9707
use strict;
9708
use warnings FATAL => 'all';
9709
use English qw(-no_match_vars);
9710
9711
use Data::Dumper;
9712
$Data::Dumper::Indent = 1;
9713
$Data::Dumper::Sortkeys = 1;
9714
$Data::Dumper::Quotekeys = 0;
9715
9716
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
9717
9718
sub new {
9719
my ( $class, %args ) = @_;
9720
9721
my $self = {
9722
server => $args{server},
9723
port => $args{port} || '11211',
9724
sessions => {},
9725
o => $args{o},
9726
};
9727
return bless $self, $class;
9728
}
9729
9730
sub parse_event {
9731
my ( $self, %args ) = @_;
9732
my @required_args = qw(event);
9733
foreach my $arg ( @required_args ) {
9734
die "I need a $arg argument" unless $args{$arg};
9735
}
9736
my $packet = @args{@required_args};
9737
9738
if ( $packet->{data_len} == 0 ) {
9739
PTDEBUG && _d('No TCP data');
9740
$args{stats}->{no_tcp_data}++ if $args{stats};
9741
return;
9742
}
9743
9744
my $src_host = "$packet->{src_host}:$packet->{src_port}";
9745
my $dst_host = "$packet->{dst_host}:$packet->{dst_port}";
9746
9747
if ( my $server = $self->{server} ) { # Watch only the given server.
9748
$server .= ":$self->{port}";
9749
if ( $src_host ne $server && $dst_host ne $server ) {
9750
PTDEBUG && _d('Packet is not to or from', $server);
9751
$args{stats}->{not_watched_server}++ if $args{stats};
9752
return;
9753
}
9754
}
9755
9756
my $packet_from;
9757
my $client;
9758
if ( $src_host =~ m/:$self->{port}$/ ) {
9759
$packet_from = 'server';
9760
$client = $dst_host;
9761
}
9762
elsif ( $dst_host =~ m/:$self->{port}$/ ) {
9763
$packet_from = 'client';
9764
$client = $src_host;
9765
}
9766
else {
9767
warn 'Packet is not to or from memcached server: ', Dumper($packet);
9768
return;
9769
}
9770
PTDEBUG && _d('Client:', $client);
9771
9772
if ( !exists $self->{sessions}->{$client} ) {
9773
PTDEBUG && _d('New session');
9774
$self->{sessions}->{$client} = {
9775
client => $client,
9776
state => undef,
9777
raw_packets => [],
9778
};
9779
};
9780
my $session = $self->{sessions}->{$client};
9781
9782
push @{$session->{raw_packets}}, $packet->{raw_packet};
9783
9784
$packet->{data} = pack('H*', $packet->{data});
9785
my $event;
9786
if ( $packet_from eq 'server' ) {
9787
$event = $self->_packet_from_server($packet, $session, %args);
9788
}
9789
elsif ( $packet_from eq 'client' ) {
9790
$event = $self->_packet_from_client($packet, $session, %args);
9791
}
9792
else {
9793
$args{stats}->{unknown_packet_origin}++ if $args{stats};
9794
die 'Packet origin unknown';
9795
}
9796
9797
PTDEBUG && _d('Done with packet; event:', Dumper($event));
9798
$args{stats}->{events_parsed}++ if $args{stats};
9799
return $event;
9800
}
9801
9802
sub _packet_from_server {
9803
my ( $self, $packet, $session, %args ) = @_;
9804
die "I need a packet" unless $packet;
9805
die "I need a session" unless $session;
9806
9807
PTDEBUG && _d('Packet is from server; client state:', $session->{state});
9808
9809
my $data = $packet->{data};
9810
9811
if ( !$session->{state} ) {
9812
PTDEBUG && _d('Ignoring mid-stream server response');
9813
$args{stats}->{ignored_midstream_server_response}++ if $args{stats};
9814
return;
9815
}
9816
9817
if ( $session->{state} eq 'awaiting reply' ) {
9818
PTDEBUG && _d('State is awaiting reply');
9819
my ($line1, $rest) = $packet->{data} =~ m/\A(.*?)\r\n(.*)?/s;
9820
if ( !$line1 ) {
9821
$args{stats}->{unknown_server_data}++ if $args{stats};
9822
die "Unknown memcached data from server";
9823
}
9824
9825
my @vals = $line1 =~ m/(\S+)/g;
9826
$session->{res} = shift @vals;
9827
PTDEBUG && _d('Result of last', $session->{cmd}, 'cmd:', $session->{res});
9828
9829
if ( $session->{cmd} eq 'incr' || $session->{cmd} eq 'decr' ) {
9830
PTDEBUG && _d('It is an incr or decr');
9831
if ( $session->{res} !~ m/\D/ ) { # It's an integer, not an error
9832
PTDEBUG && _d('Got a value for the incr/decr');
9833
$session->{val} = $session->{res};
9834
$session->{res} = '';
9835
}
9836
}
9837
elsif ( $session->{res} eq 'VALUE' ) {
9838
PTDEBUG && _d('It is the result of a "get"');
9839
my ($key, $flags, $bytes) = @vals;
9840
defined $session->{flags} or $session->{flags} = $flags;
9841
defined $session->{bytes} or $session->{bytes} = $bytes;
9842
9843
if ( $rest && $bytes ) {
9844
PTDEBUG && _d('There is a value');
9845
if ( length($rest) > $bytes ) {
9846
PTDEBUG && _d('Got complete response');
9847
$session->{val} = substr($rest, 0, $bytes);
9848
}
9849
else {
9850
PTDEBUG && _d('Got partial response, saving for later');
9851
push @{$session->{partial}}, [ $packet->{seq}, $rest ];
9852
$session->{gathered} += length($rest);
9853
$session->{state} = 'partial recv';
9854
return; # Prevent firing an event.
9855
}
9856
}
9857
}
9858
elsif ( $session->{res} eq 'END' ) {
9859
PTDEBUG && _d('Got an END without any data, firing NOT_FOUND');
9860
$session->{res} = 'NOT_FOUND';
9861
}
9862
elsif ( $session->{res} !~ m/STORED|DELETED|NOT_FOUND/ ) {
9863
PTDEBUG && _d('Unknown result');
9864
}
9865
else {
9866
$args{stats}->{unknown_server_response}++ if $args{stats};
9867
}
9868
}
9869
else { # Should be 'partial recv'
9870
PTDEBUG && _d('Session state: ', $session->{state});
9871
push @{$session->{partial}}, [ $packet->{seq}, $data ];
9872
$session->{gathered} += length($data);
9873
PTDEBUG && _d('Gathered', $session->{gathered}, 'bytes in',
9874
scalar(@{$session->{partial}}), 'packets from server');
9875
if ( $session->{gathered} >= $session->{bytes} + 2 ) { # Done.
9876
PTDEBUG && _d('End of partial response, preparing event');
9877
my $val = join('',
9878
map { $_->[1] }
9879
sort { $a->[0] <=> $b->[0] }
9880
@{$session->{partial}});
9881
$session->{val} = substr($val, 0, $session->{bytes});
9882
}
9883
else {
9884
PTDEBUG && _d('Partial response continues, no action');
9885
return; # Prevent firing event.
9886
}
9887
}
9888
9889
PTDEBUG && _d('Creating event, deleting session');
9890
my $event = make_event($session, $packet);
9891
delete $self->{sessions}->{$session->{client}}; # memcached is stateless!
9892
$session->{raw_packets} = []; # Avoid keeping forever
9893
return $event;
9894
}
9895
9896
sub _packet_from_client {
9897
my ( $self, $packet, $session, %args ) = @_;
9898
die "I need a packet" unless $packet;
9899
die "I need a session" unless $session;
9900
9901
PTDEBUG && _d('Packet is from client; state:', $session->{state});
9902
9903
my $event;
9904
if ( ($session->{state} || '') =~m/awaiting reply|partial recv/ ) {
9905
PTDEBUG && _d("Expected data from the client, looks like interrupted");
9906
$session->{res} = 'INTERRUPTED';
9907
$event = make_event($session, $packet);
9908
my $client = $session->{client};
9909
delete @{$session}{keys %$session};
9910
$session->{client} = $client;
9911
}
9912
9913
my ($line1, $val);
9914
my ($cmd, $key, $flags, $exptime, $bytes);
9915
9916
if ( !$session->{state} ) {
9917
PTDEBUG && _d('Session state: ', $session->{state});
9918
($line1, $val) = $packet->{data} =~ m/\A(.*?)\r\n(.+)?/s;
9919
if ( !$line1 ) {
9920
PTDEBUG && _d('Unknown memcached data from client, skipping packet');
9921
$args{stats}->{unknown_client_data}++ if $args{stats};
9922
return;
9923
}
9924
9925
my @vals = $line1 =~ m/(\S+)/g;
9926
$cmd = lc shift @vals;
9927
PTDEBUG && _d('$cmd is a ', $cmd);
9928
if ( $cmd eq 'set' || $cmd eq 'add' || $cmd eq 'replace' ) {
9929
($key, $flags, $exptime, $bytes) = @vals;
9930
$session->{bytes} = $bytes;
9931
}
9932
elsif ( $cmd eq 'get' ) {
9933
($key) = @vals;
9934
if ( $val ) {
9935
PTDEBUG && _d('Multiple cmds:', $val);
9936
$val = undef;
9937
}
9938
}
9939
elsif ( $cmd eq 'delete' ) {
9940
($key) = @vals; # TODO: handle the <queue_time>
9941
if ( $val ) {
9942
PTDEBUG && _d('Multiple cmds:', $val);
9943
$val = undef;
9944
}
9945
}
9946
elsif ( $cmd eq 'incr' || $cmd eq 'decr' ) {
9947
($key) = @vals;
9948
}
9949
else {
9950
PTDEBUG && _d("Don't know how to handle", $cmd, "command");
9951
$args{stats}->{unknown_client_command}++ if $args{stats};
9952
return;
9953
}
9954
9955
@{$session}{qw(cmd key flags exptime)}
9956
= ($cmd, $key, $flags, $exptime);
9957
$session->{host} = $packet->{src_host};
9958
$session->{pos_in_log} = $packet->{pos_in_log};
9959
$session->{ts} = $packet->{ts};
9960
}
9961
else {
9962
PTDEBUG && _d('Session state: ', $session->{state});
9963
$val = $packet->{data};
9964
}
9965
9966
$session->{state} = 'awaiting reply'; # Assume we got the whole packet
9967
if ( $val ) {
9968
if ( $session->{bytes} + 2 == length($val) ) { # +2 for the \r\n
9969
PTDEBUG && _d('Complete send');
9970
$val =~ s/\r\n\Z//; # We got the whole thing.
9971
$session->{val} = $val;
9972
}
9973
else { # We apparently did NOT get the whole thing.
9974
PTDEBUG && _d('Partial send, saving for later');
9975
push @{$session->{partial}},
9976
[ $packet->{seq}, $val ];
9977
$session->{gathered} += length($val);
9978
PTDEBUG && _d('Gathered', $session->{gathered}, 'bytes in',
9979
scalar(@{$session->{partial}}), 'packets from client');
9980
if ( $session->{gathered} >= $session->{bytes} + 2 ) { # Done.
9981
PTDEBUG && _d('Message looks complete now, saving value');
9982
$val = join('',
9983
map { $_->[1] }
9984
sort { $a->[0] <=> $b->[0] }
9985
@{$session->{partial}});
9986
$val =~ s/\r\n\Z//;
9987
$session->{val} = $val;
9988
}
9989
else {
9990
PTDEBUG && _d('Message not complete');
9991
$val = '[INCOMPLETE]';
9992
$session->{state} = 'partial send';
9993
}
9994
}
9995
}
9996
9997
return $event;
9998
}
9999
10000
sub make_event {
10001
my ( $session, $packet ) = @_;
10002
my $event = {
10003
cmd => $session->{cmd},
10004
key => $session->{key},
10005
val => $session->{val} || '',
10006
res => $session->{res},
10007
ts => $session->{ts},
10008
host => $session->{host},
10009
flags => $session->{flags} || 0,
10010
exptime => $session->{exptime} || 0,
10011
bytes => $session->{bytes} || 0,
10012
Query_time => timestamp_diff($session->{ts}, $packet->{ts}),
10013
pos_in_log => $session->{pos_in_log},
10014
};
10015
return $event;
10016
}
10017
10018
sub _get_errors_fh {
10019
my ( $self ) = @_;
10020
my $errors_fh = $self->{errors_fh};
10021
return $errors_fh if $errors_fh;
10022
10023
my $o = $self->{o};
10024
if ( $o && $o->has('tcpdump-errors') && $o->got('tcpdump-errors') ) {
10025
my $errors_file = $o->get('tcpdump-errors');
10026
PTDEBUG && _d('tcpdump-errors file:', $errors_file);
10027
open $errors_fh, '>>', $errors_file
10028
or die "Cannot open tcpdump-errors file $errors_file: $OS_ERROR";
10029
}
10030
10031
$self->{errors_fh} = $errors_fh;
10032
return $errors_fh;
10033
}
10034
10035
sub _d {
10036
my ($package, undef, $line) = caller 0;
10037
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
10038
map { defined $_ ? $_ : 'undef' }
10039
@_;
10040
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
10041
}
10042
10043
sub timestamp_diff {
10044
my ( $start, $end ) = @_;
10045
my $sd = substr($start, 0, 11, '');
10046
my $ed = substr($end, 0, 11, '');
10047
my ( $sh, $sm, $ss ) = split(/:/, $start);
10048
my ( $eh, $em, $es ) = split(/:/, $end);
10049
my $esecs = ($eh * 3600 + $em * 60 + $es);
10050
my $ssecs = ($sh * 3600 + $sm * 60 + $ss);
10051
if ( $sd eq $ed ) {
10052
return sprintf '%.6f', $esecs - $ssecs;
10053
}
10054
else { # Assume only one day boundary has been crossed, no DST, etc
10055
return sprintf '%.6f', ( 86_400 - $ssecs ) + $esecs;
10056
}
10057
}
10058
10059
1;
10060
}
10061
# ###########################################################################
10062
# End MemcachedProtocolParser package
10063
# ###########################################################################
10064
10065
# ###########################################################################
10066
# MemcachedEvent package
10067
# This package is a copy without comments from the original. The original
10068
# with comments and its test file can be found in the Bazaar repository at,
10069
# lib/MemcachedEvent.pm
10070
# t/lib/MemcachedEvent.t
10071
# See https://launchpad.net/percona-toolkit for more information.
10072
# ###########################################################################
10073
{
10074
package MemcachedEvent;
10075
10076
use strict;
10077
use warnings FATAL => 'all';
10078
use English qw(-no_match_vars);
10079
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
10080
10081
use Data::Dumper;
10082
$Data::Dumper::Indent = 1;
10083
$Data::Dumper::Sortkeys = 1;
10084
$Data::Dumper::Quotekeys = 0;
10085
10086
my %cmds = map { $_ => 1 } qw(
10087
set
10088
add
10089
replace
10090
append
10091
prepend
10092
cas
10093
get
10094
gets
10095
delete
10096
incr
10097
decr
10098
);
10099
10100
my %cmd_handler_for = (
10101
set => \&handle_storage_cmd,
10102
add => \&handle_storage_cmd,
10103
replace => \&handle_storage_cmd,
10104
append => \&handle_storage_cmd,
10105
prepend => \&handle_storage_cmd,
10106
cas => \&handle_storage_cmd,
10107
get => \&handle_retr_cmd,
10108
gets => \&handle_retr_cmd,
10109
);
10110
10111
sub new {
10112
my ( $class, %args ) = @_;
10113
my $self = {};
10114
return bless $self, $class;
10115
}
10116
10117
sub parse_event {
10118
my ( $self, %args ) = @_;
10119
my $event = $args{event};
10120
return unless $event;
10121
10122
if ( !$event->{cmd} || !$event->{key} ) {
10123
PTDEBUG && _d('Event has no cmd or key:', Dumper($event));
10124
return;
10125
}
10126
10127
if ( !$cmds{$event->{cmd}} ) {
10128
PTDEBUG && _d("Don't know how to handle cmd:", $event->{cmd});
10129
return;
10130
}
10131
10132
$event->{arg} = "$event->{cmd} $event->{key}";
10133
$event->{fingerprint} = $self->fingerprint($event->{arg});
10134
$event->{key_print} = $self->fingerprint($event->{key});
10135
10136
map { $event->{"Memc_$_"} = 'No' } keys %cmds;
10137
$event->{"Memc_$event->{cmd}"} = 'Yes'; # Got this cmd.
10138
$event->{Memc_error} = 'No'; # A handler may change this.
10139
$event->{Memc_miss} = 'No';
10140
if ( $event->{res} ) {
10141
$event->{Memc_miss} = 'Yes' if $event->{res} eq 'NOT_FOUND';
10142
}
10143
else {
10144
PTDEBUG && _d('Event has no res:', Dumper($event));
10145
}
10146
10147
if ( $cmd_handler_for{$event->{cmd}} ) {
10148
return $cmd_handler_for{$event->{cmd}}->($event);
10149
}
10150
10151
return $event;
10152
}
10153
10154
sub fingerprint {
10155
my ( $self, $val ) = @_;
10156
$val =~ s/[0-9A-Fa-f]{16,}|\d+/?/g;
10157
return $val;
10158
}
10159
10160
sub handle_storage_cmd {
10161
my ( $event ) = @_;
10162
10163
if ( !$event->{res} ) {
10164
PTDEBUG && _d('No result for event:', Dumper($event));
10165
return;
10166
}
10167
10168
$event->{'Memc_Not_Stored'} = $event->{res} eq 'NOT_STORED' ? 'Yes' : 'No';
10169
$event->{'Memc_Exists'} = $event->{res} eq 'EXISTS' ? 'Yes' : 'No';
10170
10171
return $event;
10172
}
10173
10174
sub handle_retr_cmd {
10175
my ( $event ) = @_;
10176
10177
if ( !$event->{res} ) {
10178
PTDEBUG && _d('No result for event:', Dumper($event));
10179
return;
10180
}
10181
10182
$event->{'Memc_error'} = $event->{res} eq 'INTERRUPTED' ? 'Yes' : 'No';
10183
10184
return $event;
10185
}
10186
10187
10188
sub handle_delete {
10189
my ( $event ) = @_;
10190
return $event;
10191
}
10192
10193
sub handle_incr_decr_cmd {
10194
my ( $event ) = @_;
10195
return $event;
10196
}
10197
10198
sub _d {
10199
my ($package, undef, $line) = caller 0;
10200
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
10201
map { defined $_ ? $_ : 'undef' }
10202
@_;
10203
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
10204
}
10205
10206
1;
10207
}
10208
# ###########################################################################
10209
# End MemcachedEvent package
10210
# ###########################################################################
10211
10212
# ###########################################################################
10213
9076
# BinaryLogParser package
10214
9077
# This package is a copy without comments from the original. The original
10215
9078
# with comments and its test file can be found in the Bazaar repository at,
10960
9823
# ###########################################################################
10961
9824
10962
9825
# ###########################################################################
10963
# HTTPProtocolParser package
10964
# This package is a copy without comments from the original. The original
10965
# with comments and its test file can be found in the Bazaar repository at,
10966
# lib/HTTPProtocolParser.pm
10967
# t/lib/HTTPProtocolParser.t
10968
# See https://launchpad.net/percona-toolkit for more information.
10969
# ###########################################################################
10970
{
10971
package HTTPProtocolParser;
10972
use base 'ProtocolParser';
10973
10974
use strict;
10975
use warnings FATAL => 'all';
10976
use English qw(-no_match_vars);
10977
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
10978
10979
sub new {
10980
my ( $class, %args ) = @_;
10981
my $self = $class->SUPER::new(
10982
%args,
10983
port => 80,
10984
);
10985
return $self;
10986
}
10987
10988
sub _packet_from_server {
10989
my ( $self, $packet, $session, $misc ) = @_;
10990
die "I need a packet" unless $packet;
10991
die "I need a session" unless $session;
10992
10993
PTDEBUG && _d('Packet is from server; client state:', $session->{state});
10994
10995
if ( !$session->{state} ) {
10996
PTDEBUG && _d('Ignoring mid-stream server response');
10997
return;
10998
}
10999
11000
if ( $session->{out_of_order} ) {
11001
my ($line1, $content);
11002
if ( !$session->{have_header} ) {
11003
($line1, $content) = $self->_parse_header(
11004
$session, $packet->{data}, $packet->{data_len});
11005
}
11006
if ( $line1 ) {
11007
$session->{have_header} = 1;
11008
$packet->{content_len} = length $content;
11009
PTDEBUG && _d('Got out of order header with',
11010
$packet->{content_len}, 'bytes of content');
11011
}
11012
my $have_len = $packet->{content_len} || $packet->{data_len};
11013
map { $have_len += $_->{data_len} }
11014
@{$session->{packets}};
11015
$session->{have_all_packets}
11016
= 1 if $session->{attribs}->{bytes}
11017
&& $have_len >= $session->{attribs}->{bytes};
11018
PTDEBUG && _d('Have', $have_len, 'of', $session->{attribs}->{bytes});
11019
return;
11020
}
11021
11022
if ( $session->{state} eq 'awaiting reply' ) {
11023
11024
$session->{start_reply} = $packet->{ts} unless $session->{start_reply};
11025
11026
my ($line1, $content) = $self->_parse_header($session, $packet->{data},
11027
$packet->{data_len});
11028
11029
if ( !$line1 ) {
11030
$session->{out_of_order} = 1; # alert parent
11031
$session->{have_all_packets} = 0;
11032
return;
11033
}
11034
11035
my ($version, $code, $phrase) = $line1 =~ m/(\S+)/g;
11036
$session->{attribs}->{Status_code} = $code;
11037
PTDEBUG && _d('Status code for last', $session->{attribs}->{arg},
11038
'request:', $session->{attribs}->{Status_code});
11039
11040
my $content_len = $content ? length $content : 0;
11041
PTDEBUG && _d('Got', $content_len, 'bytes of content');
11042
if ( $session->{attribs}->{bytes}
11043
&& $content_len < $session->{attribs}->{bytes} ) {
11044
$session->{data_len} = $session->{attribs}->{bytes};
11045
$session->{buff} = $content;
11046
$session->{buff_left} = $session->{attribs}->{bytes} - $content_len;
11047
PTDEBUG && _d('Contents not complete,', $session->{buff_left},
11048
'bytes left');
11049
$session->{state} = 'recving content';
11050
return;
11051
}
11052
}
11053
elsif ( $session->{state} eq 'recving content' ) {
11054
if ( $session->{buff} ) {
11055
PTDEBUG && _d('Receiving content,', $session->{buff_left},
11056
'bytes left');
11057
return;
11058
}
11059
PTDEBUG && _d('Contents received');
11060
}
11061
else {
11062
warn "Server response in unknown state";
11063
return;
11064
}
11065
11066
PTDEBUG && _d('Creating event, deleting session');
11067
$session->{end_reply} = $session->{ts_max} || $packet->{ts};
11068
my $event = $self->make_event($session, $packet);
11069
delete $self->{sessions}->{$session->{client}}; # http is stateless!
11070
return $event;
11071
}
11072
11073
sub _packet_from_client {
11074
my ( $self, $packet, $session, $misc ) = @_;
11075
die "I need a packet" unless $packet;
11076
die "I need a session" unless $session;
11077
11078
PTDEBUG && _d('Packet is from client; state:', $session->{state});
11079
11080
my $event;
11081
if ( ($session->{state} || '') =~ m/awaiting / ) {
11082
PTDEBUG && _d('More client headers:', $packet->{data});
11083
return;
11084
}
11085
11086
if ( !$session->{state} ) {
11087
$session->{state} = 'awaiting reply';
11088
my ($line1, undef) = $self->_parse_header($session, $packet->{data}, $packet->{data_len});
11089
my ($request, $page, $version) = $line1 =~ m/(\S+)/g;
11090
if ( !$request || !$page ) {
11091
PTDEBUG && _d("Didn't get a request or page:", $request, $page);
11092
return;
11093
}
11094
$request = lc $request;
11095
my $vh = $session->{attribs}->{Virtual_host} || '';
11096
my $arg = "$request $vh$page";
11097
PTDEBUG && _d('arg:', $arg);
11098
11099
if ( $request eq 'get' || $request eq 'post' ) {
11100
@{$session->{attribs}}{qw(arg)} = ($arg);
11101
}
11102
else {
11103
PTDEBUG && _d("Don't know how to handle a", $request, "request");
11104
return;
11105
}
11106
11107
$session->{start_request} = $packet->{ts};
11108
$session->{attribs}->{host} = $packet->{src_host};
11109
$session->{attribs}->{pos_in_log} = $packet->{pos_in_log};
11110
$session->{attribs}->{ts} = $packet->{ts};
11111
}
11112
else {
11113
die "Probably multiple GETs from client before a server response?";
11114
}
11115
11116
return $event;
11117
}
11118
11119
sub _parse_header {
11120
my ( $self, $session, $data, $len, $no_recurse ) = @_;
11121
die "I need data" unless $data;
11122
my ($header, $content) = split(/\r\n\r\n/, $data);
11123
my ($line1, $header_vals) = $header =~ m/\A(\S+ \S+ .+?)\r\n(.+)?/s;
11124
PTDEBUG && _d('HTTP header:', $line1);
11125
return unless $line1;
11126
11127
if ( !$header_vals ) {
11128
PTDEBUG && _d('No header vals');
11129
return $line1, undef;
11130
}
11131
my @headers;
11132
foreach my $val ( split(/\r\n/, $header_vals) ) {
11133
last unless $val;
11134
PTDEBUG && _d('HTTP header:', $val);
11135
if ( $val =~ m/^Content-Length/i ) {
11136
($session->{attribs}->{bytes}) = $val =~ /: (\d+)/;
11137
PTDEBUG && _d('Saved Content-Length:', $session->{attribs}->{bytes});
11138
}
11139
if ( $val =~ m/Content-Encoding/i ) {
11140
($session->{compressed}) = $val =~ /: (\w+)/;
11141
PTDEBUG && _d('Saved Content-Encoding:', $session->{compressed});
11142
}
11143
if ( $val =~ m/^Host/i ) {
11144
($session->{attribs}->{Virtual_host}) = $val =~ /: (\S+)/;
11145
PTDEBUG && _d('Saved Host:', ($session->{attribs}->{Virtual_host}));
11146
}
11147
}
11148
return $line1, $content;
11149
}
11150
11151
sub _d {
11152
my ($package, undef, $line) = caller 0;
11153
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
11154
map { defined $_ ? $_ : 'undef' }
11155
@_;
11156
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
11157
}
11158
11159
1;
11160
}
11161
# ###########################################################################
11162
# End HTTPProtocolParser package
11163
# ###########################################################################
11164
11165
# ###########################################################################
11166
9826
# MasterSlave package
11167
9827
# This package is a copy without comments from the original. The original
11168
9828
# with comments and its test file can be found in the Bazaar repository at,
14143
12803
binlog => ['BinaryLogParser'],
14144
12804
genlog => ['GeneralLogParser'],
14145
12805
tcpdump => ['TcpdumpParser','MySQLProtocolParser'],
14146
memcached => ['TcpdumpParser','MemcachedProtocolParser',
14147
'MemcachedEvent'],
14148
http => ['TcpdumpParser','HTTPProtocolParser'],
14149
pglog => ['PgLogParser'],
14150
12806
rawlog => ['RawLogParser'],
14151
12807
);
14152
12808
my $type = $o->get('type');
14700
13356
14701
13357
{ # distill
14702
13358
my %distill_args;
14703
if ( $o->get('type') eq 'memcached' || $o->get('type') eq 'http' ) {
14704
$distill_args{generic} = 1;
14705
if ( $o->get('type') eq 'http' ) {
14706
# Remove stuff after url.
14707
$distill_args{trf} = sub {
14708
my ( $query ) = @_;
14709
$query =~ s/(\S+ \S+?)(?:[?;].+)/$1/;
14710
return $query;
14711
};
14712
}
14713
}
14714
13359
if ( grep { $_ eq 'distill' } @groupby ) {
14715
13360
$pipeline->add(
14716
13361
name => 'distill',
15439
14084
15440
14085
=head1 NAME
15441
14086
15442
pt-query-digest - Analyze query execution logs and generate a query report, filter, replay, or transform queries for MySQL, PostgreSQL, memcached, and more.
14087
pt-query-digest - Analyze query execution logs and generate a query report, filter, replay, or transform queries for MySQL.
15443
14088
15444
14089
=head1 SYNOPSIS
15445
14090
15544
14189
Attributes created this way can be specified for L<"--order-by"> or any
15545
14190
option that requires an attribute.
15546
14191
15547
=head2 memcached
15548
15549
memcached events have additional attributes related to the memcached protocol:
15550
cmd, key, res (result) and val. Also, boolean attributes are created for
15551
the various commands, misses and errors: Memc_CMD where CMD is a memcached
15552
command (get, set, delete, etc.), Memc_error and Memc_miss.
15553
15554
These attributes are no different from slow log attributes, so you can use them
15555
with L<"--[no]report">, L<"--group-by">, in a L<"--filter">, etc.
15556
15557
See the memcached section of L<"ATTRIBUTES REFERENCE"> for a list of
15558
memcached-specific attributes.
15559
15560
14192
=head1 OUTPUT
15561
14193
15562
14194
The default output is a query analysis report. The L<"--[no]report"> option
15814
14446
You can also use the value C<distill>, which is a kind of super-fingerprint.
15815
14447
See L<"--group-by"> for more.
15816
14448
15817
When parsing memcached input (L<"--type"> memcached), the fingerprint is an
15818
abstracted version of the command and key, with placeholders removed. For
15819
example, C<get user_123_preferences> fingerprints to C<get user_?_preferences>.
15820
There is also a C<key_print> which a fingerprinted version of the key. This
15821
example's key_print is C<user_?_preferences>.
15822
15823
14449
Query fingerprinting accommodates a great many special cases, which have proven
15824
14450
necessary in the real world. For example, an IN list with 5 literals is really
15825
14451
equivalent to one with 4 literals, so lists of literals are collapsed to a
16184
14810
16185
14811
=back
16186
14812
16187
If parsing memcached input (L<"--type"> memcached), there are other
16188
attributes which you can group by: key_print (see memcached section in
16189
L<"FINGERPRINTS">), cmd, key, res and val (see memcached section in
16190
L<"ATTRIBUTES">).
16191
16192
14813
=item --help
16193
14814
16194
14815
Show help and exit.
16918
15539
notably C<Query_time>. The default L<"--order-by"> for general logs
16919
15540
changes to C<Query_time:cnt>.
16920
15541
16921
=item http
16922
16923
Parse HTTP traffic from tcpdump.
16924
16925
=item pglog
16926
16927
Parse a log file in PostgreSQL format. The parser will automatically recognize
16928
logs sent to syslog and transparently parse the syslog format, too. The
16929
recommended configuration for logging in your postgresql.conf is as follows.
16930
16931
The log_destination setting can be set to either syslog or stderr. Syslog has
16932
the added benefit of not interleaving log messages from several sessions
16933
concurrently, which the parser cannot handle, so this might be better than
16934
stderr. CSV-formatted logs are not supported at this time.
16935
16936
The log_min_duration_statement setting should be set to 0 to capture all
16937
statements with their durations. Alternatively, the parser will also recognize
16938
and handle various combinations of log_duration and log_statement.
16939
16940
You may enable log_connections and log_disconnections, but this is optional.
16941
16942
It is highly recommended to set your log_line_prefix to the following:
16943
16944
log_line_prefix = '%m c=%c,u=%u,D=%d '
16945
16946
This lets the parser find timestamps with milliseconds, session IDs, users, and
16947
databases from the log. If these items are missing, you'll simply get less
16948
information to analyze. For compatibility with other log analysis tools such as
16949
PQA and pgfouine, various log line prefix formats are supported. The general
16950
format is as follows: a timestamp can be detected and extracted (the syslog
16951
timestamp is NOT parsed), and a name=value list of properties can also.
16952
Although the suggested format is as shown above, any name=value list will be
16953
captured and interpreted by using the first letter of the 'name' part,
16954
lowercased, to determine the meaning of the item. The lowercased first letter
16955
is interpreted to mean the same thing as PostgreSQL's built-in %-codes for the
16956
log_line_prefix format string. For example, u means user, so unicorn=fred
16957
will be interpreted as user=fred; d means database, so D=john will be
16958
interpreted as database=john. The pgfouine-suggested formatting is user=%u and
16959
db=%d, so it should Just Work regardless of which format you choose. The main
16960
thing is to add as much information as possible into the log_line_prefix to
16961
permit richer analysis.
16962
16963
Currently, only English locale messages are supported, so if your server's
16964
locale is set to something else, the log won't be parsed properly. (Log
16965
messages with "duration:" and "statement:" won't be recognized.)
16966
16967
15542
=item slowlog
16968
15543
16969
15544
Parse a log file in any variation of MySQL slow-log format.
17029
15604
Server-side prepared statements are supported. SSL-encrypted traffic cannot be
17030
15605
inspected and decoded.
17031
15606
17032
=item memcached
17033
17034
Similar to tcpdump, but the expected input is memcached packets
17035
instead of MySQL packets. For example:
17036
17037
tcpdump -i any port 11211 -s 65535 -x -nn -q -tttt \
17038
> memcached.tcp.txt
17039
pt-query-digest --type memcached memcached.tcp.txt
17040
17041
memcached uses port 11211 by default.
17042
17043
15607
=back
17044
15608
17045
15609
=item --until
17114
15678
type: string
17115
15679
17116
15680
This option tells pt-query-digest which server IP address and port (like
17117
"10.0.0.1:3306") to watch when parsing tcpdump (for L<"--type"> tcpdump and
17118
memcached); all other servers are ignored. If you don't specify it,
15681
"10.0.0.1:3306") to watch when parsing tcpdump (for L<"--type"> tcpdump);
15682
all other servers are ignored. If you don't specify it,
17119
15683
pt-query-digest watches all servers by looking for any IP address using port
17120
15684
3306 or "mysql". If you're watching a server with a non-standard port, this
17121
15685
won't work, so you must specify the IP address and port to watch.
17308
15872
17309
15873
=item cmd
17310
15874
17311
"Query" or "Admin" for all except memcached. For memcached it's
17312
the memcached command: get, set, etc.
15875
"Query" or "Admin".
17313
15876
17314
15877
=item db
17315
15878
17316
The current database, except for memcached. The value comes from USE
17317
database statements. By default, C<Schema> is an alias which is automatically
15879
The current database. The value comes from USE database statements.
15880
By default, C<Schema> is an alias which is automatically
17318
15881
changed to C<db>; see L<"--attribute-aliases">.
17319
15882
17320
15883
=item fingerprint
17387
15950
If using L<"--processlist">, an C<id> attribute is available for
17388
15951
the process ID, in addition to the common attributes.
17389
15952
17390
=head2 MEMCACHED
17391
17392
These attributes are available when parsing L<"--type"> memcached.
17393
17394
=over
17395
17396
=item exptime
17397
17398
Expiration time.
17399
17400
=item key
17401
17402
The key used by cmd.
17403
17404
=item key_print
17405
17406
An abstracted form of the key.
17407
17408
=item Memc_add
17409
17410
Yes/No if the command is add.
17411
17412
=item Memc_append
17413
17414
Yes/No if the command is append.
17415
17416
=item Memc_cas
17417
17418
Yes/No if the command is cas.
17419
17420
=item Memc_error
17421
17422
Yes/No if command caused an error. Currently, the only error is when
17423
a retrieval command is interrupted.
17424
17425
=item Memc_get
17426
17427
Yes/No if the command is get.
17428
17429
=item Memc_gets
17430
17431
Yes/No if the command is gets.
17432
17433
=item Memc_miss
17434
17435
Yes/No if the command tried to access a nonexistent key.
17436
17437
=item Memc_prepend
17438
17439
Yes/No if the command is prepend.
17440
17441
=item Memc_replace
17442
17443
Yes/No if the command is replace.
17444
17445
=item Memc_set
17446
17447
Yes/No if the command is set.
17448
17449
=item res
17450
17451
Result of cmd.
17452
17453
=item val
17454
17455
The return value of cmd, if any.
17456
17457
=back
17458
17459
15953
=head1 AUTHORS
17460
15954
17461
15955
Baron Schwartz and Daniel Nichter
Loggerhead is a web-based interface for Breezy
Version: 2.0.1