Merge lp:~percona-toolkit-dev/percona-toolkit/simplify-pqd into lp:percona-toolkit/2.2

Proposed by Brian Fraser
Status: Merged
Approved by: Daniel Nichter
Approved revision: 518
Merged at revision: 514
Proposed branch: lp:~percona-toolkit-dev/percona-toolkit/simplify-pqd
Merge into: lp:percona-toolkit/2.2
Diff against target: 224909 lines (+12/-224362)
75 files modified
bin/pt-query-digest (+8/-1514)
lib/HTTPProtocolParser.pm (+0/-242)
lib/MemcachedEvent.pm (+0/-216)
lib/MemcachedProtocolParser.pm (+0/-424)
lib/PgLogParser.pm (+0/-669)
lib/QueryReportFormatter.pm (+1/-3)
lib/SysLogParser.pm (+0/-259)
lib/TcpdumpParser.pm (+1/-4)
t/lib/HTTPProtocolParser.t (+0/-286)
t/lib/MemcachedEvent.t (+0/-766)
t/lib/MemcachedProtocolParser.t (+0/-414)
t/lib/PgLogParser.t (+0/-604)
t/lib/SysLogParser.t (+0/-205)
t/lib/samples/http/http_tcpdump001.txt (+0/-107)
t/lib/samples/http/http_tcpdump002.txt (+0/-3564)
t/lib/samples/http/http_tcpdump003.txt (+0/-16163)
t/lib/samples/http/http_tcpdump004.txt (+0/-898)
t/lib/samples/http/http_tcpdump005.txt (+0/-465)
t/lib/samples/http/http_tcpdump006.txt (+0/-322)
t/lib/samples/http/http_tcpdump007.txt (+0/-184146)
t/lib/samples/http/http_tcpdump008.txt (+0/-112)
t/lib/samples/http/http_tcpdump009.txt (+0/-106)
t/lib/samples/memcached/memc_tcpdump001.txt (+0/-12)
t/lib/samples/memcached/memc_tcpdump002.txt (+0/-13)
t/lib/samples/memcached/memc_tcpdump003.txt (+0/-20)
t/lib/samples/memcached/memc_tcpdump004.txt (+0/-60)
t/lib/samples/memcached/memc_tcpdump005.txt (+0/-1163)
t/lib/samples/memcached/memc_tcpdump006.txt (+0/-1170)
t/lib/samples/memcached/memc_tcpdump007.txt (+0/-11)
t/lib/samples/memcached/memc_tcpdump008.txt (+0/-121)
t/lib/samples/memcached/memc_tcpdump009.txt (+0/-11)
t/lib/samples/memcached/memc_tcpdump010.txt (+0/-11)
t/lib/samples/memcached/memc_tcpdump011.txt (+0/-25)
t/lib/samples/memcached/memc_tcpdump013.txt (+0/-6)
t/lib/samples/memcached/memc_tcpdump014.txt (+0/-19)
t/lib/samples/memcached/memc_tcpdump015.txt (+0/-25)
t/lib/samples/memcached/memc_tcpdump016.txt (+0/-37)
t/lib/samples/pg/pg-log-001.txt (+0/-8)
t/lib/samples/pg/pg-log-002.txt (+0/-15)
t/lib/samples/pg/pg-log-003.txt (+0/-10)
t/lib/samples/pg/pg-log-004.txt (+0/-4)
t/lib/samples/pg/pg-log-005.txt (+0/-6)
t/lib/samples/pg/pg-log-006.txt (+0/-16)
t/lib/samples/pg/pg-log-007.txt (+0/-13)
t/lib/samples/pg/pg-log-008.txt (+0/-3)
t/lib/samples/pg/pg-log-009.txt (+0/-2980)
t/lib/samples/pg/pg-log-010.txt (+0/-3693)
t/lib/samples/pg/pg-syslog-001.txt (+0/-13)
t/lib/samples/pg/pg-syslog-002.txt (+0/-5)
t/lib/samples/pg/pg-syslog-003.txt (+0/-14)
t/lib/samples/pg/pg-syslog-004.txt (+0/-8)
t/lib/samples/pg/pg-syslog-005.txt (+0/-5)
t/lib/samples/pg/pg-syslog-006.txt (+0/-9)
t/lib/samples/pg/pg-syslog-007.txt (+0/-11)
t/lib/samples/pg/pg-syslog-008.txt (+0/-123)
t/lib/samples/pg/pg-syslog-009.txt (+0/-2437)
t/lib/samples/pg/pg-syslog-010.txt (+0/-23)
t/pt-query-digest/http_analyses.t (+0/-26)
t/pt-query-digest/memcached_analyses.t (+0/-90)
t/pt-query-digest/pglog_analyses.t (+0/-44)
t/pt-query-digest/resume.t (+2/-2)
t/pt-query-digest/samples/http_tcpdump002.txt (+0/-240)
t/pt-query-digest/samples/memc_tcpdump001.txt (+0/-25)
t/pt-query-digest/samples/memc_tcpdump002.txt (+0/-25)
t/pt-query-digest/samples/memc_tcpdump003.txt (+0/-50)
t/pt-query-digest/samples/memc_tcpdump003_report_key_print.txt (+0/-29)
t/pt-query-digest/samples/memc_tcpdump004.txt (+0/-52)
t/pt-query-digest/samples/memc_tcpdump005.txt (+0/-25)
t/pt-query-digest/samples/memc_tcpdump006.txt (+0/-25)
t/pt-query-digest/samples/memc_tcpdump007.txt (+0/-26)
t/pt-query-digest/samples/memc_tcpdump008.txt (+0/-26)
t/pt-query-digest/samples/memc_tcpdump009.txt (+0/-26)
t/pt-query-digest/samples/memc_tcpdump010.txt (+0/-25)
t/pt-query-digest/samples/pg-sample1 (+0/-25)
t/pt-query-digest/samples/pg-syslog-sample1 (+0/-12)
To merge this branch: bzr merge lp:~percona-toolkit-dev/percona-toolkit/simplify-pqd
Reviewer Review Type Date Requested Status
Daniel Nichter Approve
Review via email: mp+146196@code.launchpad.net
To post a comment you must log in.
Revision history for this message
Daniel Nichter (daniel-nichter) wrote :

The changes will be/are so extensive as to be beyond the point of pointed review. Just test on all platforms, and when tests are passing, merge.

review: Approve
Revision history for this message
Daniel Nichter (daniel-nichter) wrote :

Preview Diff

[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
=== modified file 'bin/pt-query-digest'
--- bin/pt-query-digest 2013-01-31 17:52:34 +0000
+++ bin/pt-query-digest 2013-02-01 18:19:34 +0000
@@ -23,8 +23,6 @@
23 Processlist23 Processlist
24 TcpdumpParser24 TcpdumpParser
25 MySQLProtocolParser25 MySQLProtocolParser
26 SysLogParser
27 PgLogParser
28 SlowLogParser26 SlowLogParser
29 SlowLogWriter27 SlowLogWriter
30 EventAggregator28 EventAggregator
@@ -36,13 +34,10 @@
36 TableParser34 TableParser
37 QueryReview35 QueryReview
38 Daemon36 Daemon
39 MemcachedProtocolParser
40 MemcachedEvent
41 BinaryLogParser37 BinaryLogParser
42 GeneralLogParser38 GeneralLogParser
43 RawLogParser39 RawLogParser
44 ProtocolParser40 ProtocolParser
45 HTTPProtocolParser
46 MasterSlave41 MasterSlave
47 Progress42 Progress
48 FileIterator43 FileIterator
@@ -3283,10 +3278,7 @@
3283sub port_number {3278sub port_number {
3284 my ( $self, $port ) = @_;3279 my ( $self, $port ) = @_;
3285 return unless $port;3280 return unless $port;
3286 return $port eq 'memcached' ? 112113281 return $port eq 'mysql' ? 3306 : $port;
3287 : $port eq 'http' ? 80
3288 : $port eq 'mysql' ? 3306
3289 : $port;
3290}3282}
32913283
3292sub _d {3284sub _d {
@@ -4587,617 +4579,6 @@
4587# ###########################################################################4579# ###########################################################################
45884580
4589# ###########################################################################4581# ###########################################################################
4590# SysLogParser package
4591# This package is a copy without comments from the original. The original
4592# with comments and its test file can be found in the Bazaar repository at,
4593# lib/SysLogParser.pm
4594# t/lib/SysLogParser.t
4595# See https://launchpad.net/percona-toolkit for more information.
4596# ###########################################################################
4597{
4598package SysLogParser;
4599
4600use strict;
4601use warnings FATAL => 'all';
4602use English qw(-no_match_vars);
4603use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4604
4605my $syslog_regex = qr{\A.*\w+\[\d+\]: \[(\d+)-(\d+)\] (.*)\Z};
4606
4607sub new {
4608 my ( $class ) = @_;
4609 my $self = {};
4610 return bless $self, $class;
4611}
4612
4613sub parse_event {
4614 my ( $self, %args ) = @_;
4615 my ( $next_event, $tell, $is_syslog ) = $self->generate_wrappers(%args);
4616 return $next_event->();
4617}
4618
4619sub generate_wrappers {
4620 my ( $self, %args ) = @_;
4621
4622 if ( ($self->{sanity} || '') ne "$args{next_event}" ){
4623 PTDEBUG && _d("Clearing and recreating internal state");
4624 @{$self}{qw(next_event tell is_syslog)} = $self->make_closures(%args);
4625 $self->{sanity} = "$args{next_event}";
4626 }
4627
4628 return @{$self}{qw(next_event tell is_syslog)};
4629}
4630
4631sub make_closures {
4632 my ( $self, %args ) = @_;
4633
4634 my $next_event = $args{'next_event'};
4635 my $tell = $args{'tell'};
4636 my $new_event_test = $args{'misc'}->{'new_event_test'};
4637 my $line_filter = $args{'misc'}->{'line_filter'};
4638
4639 my $test_line = $next_event->();
4640 PTDEBUG && _d('Read first sample/test line:', $test_line);
4641
4642 if ( defined $test_line && $test_line =~ m/$syslog_regex/o ) {
4643
4644 PTDEBUG && _d('This looks like a syslog line, PTDEBUG prefix=LLSP');
4645
4646 my ($msg_nr, $line_nr, $content) = $test_line =~ m/$syslog_regex/o;
4647 my @pending = ($test_line);
4648 my $last_msg_nr = $msg_nr;
4649 my $pos_in_log = 0;
4650
4651 my $new_next_event = sub {
4652 PTDEBUG && _d('LLSP: next_event()');
4653
4654 PTDEBUG && _d('LLSP: Current virtual $fh position:', $pos_in_log);
4655 my $new_pos = 0;
4656
4657 my @arg_lines;
4658
4659 my $line;
4660 LINE:
4661 while (
4662 defined($line = shift @pending)
4663 || do {
4664 eval { $new_pos = -1; $new_pos = $tell->() };
4665 defined($line = $next_event->());
4666 }
4667 ) {
4668 PTDEBUG && _d('LLSP: Line:', $line);
4669
4670 ($msg_nr, $line_nr, $content) = $line =~ m/$syslog_regex/o;
4671 if ( !$msg_nr ) {
4672 die "Can't parse line: $line";
4673 }
4674
4675 elsif ( $msg_nr != $last_msg_nr ) {
4676 PTDEBUG && _d('LLSP: $msg_nr', $last_msg_nr, '=>', $msg_nr);
4677 $last_msg_nr = $msg_nr;
4678 last LINE;
4679 }
4680
4681 elsif ( @arg_lines && $new_event_test && $new_event_test->($content) ) {
4682 PTDEBUG && _d('LLSP: $new_event_test matches');
4683 last LINE;
4684 }
4685
4686 $content =~ s/#(\d{3})/chr(oct($1))/ge;
4687 $content =~ s/\^I/\t/g;
4688 if ( $line_filter ) {
4689 PTDEBUG && _d('LLSP: applying $line_filter');
4690 $content = $line_filter->($content);
4691 }
4692
4693 push @arg_lines, $content;
4694 }
4695 PTDEBUG && _d('LLSP: Exited while-loop after finding a complete entry');
4696
4697 my $psql_log_event = @arg_lines ? join('', @arg_lines) : undef;
4698 PTDEBUG && _d('LLSP: Final log entry:', $psql_log_event);
4699
4700 if ( defined $line ) {
4701 PTDEBUG && _d('LLSP: Saving $line:', $line);
4702 @pending = $line;
4703 PTDEBUG && _d('LLSP: $pos_in_log:', $pos_in_log, '=>', $new_pos);
4704 $pos_in_log = $new_pos;
4705 }
4706 else {
4707 PTDEBUG && _d('LLSP: EOF reached');
4708 @pending = ();
4709 $last_msg_nr = 0;
4710 }
4711
4712 return $psql_log_event;
4713 };
4714
4715 my $new_tell = sub {
4716 PTDEBUG && _d('LLSP: tell()', $pos_in_log);
4717 return $pos_in_log;
4718 };
4719
4720 return ($new_next_event, $new_tell, 1);
4721 }
4722
4723 else {
4724
4725 PTDEBUG && _d('Plain log, or we are at EOF; PTDEBUG prefix=PLAIN');
4726
4727 my @pending = defined $test_line ? ($test_line) : ();
4728
4729 my $new_next_event = sub {
4730 PTDEBUG && _d('PLAIN: next_event(); @pending:', scalar @pending);
4731 return @pending ? shift @pending : $next_event->();
4732 };
4733 my $new_tell = sub {
4734 PTDEBUG && _d('PLAIN: tell(); @pending:', scalar @pending);
4735 return @pending ? 0 : $tell->();
4736 };
4737 return ($new_next_event, $new_tell, 0);
4738 }
4739}
4740
4741sub _d {
4742 my ($package, undef, $line) = caller 0;
4743 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4744 map { defined $_ ? $_ : 'undef' }
4745 @_;
4746 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4747}
4748
47491;
4750}
4751# ###########################################################################
4752# End SysLogParser package
4753# ###########################################################################
4754
4755# ###########################################################################
4756# PgLogParser package
4757# This package is a copy without comments from the original. The original
4758# with comments and its test file can be found in the Bazaar repository at,
4759# lib/PgLogParser.pm
4760# t/lib/PgLogParser.t
4761# See https://launchpad.net/percona-toolkit for more information.
4762# ###########################################################################
4763{
4764package PgLogParser;
4765
4766use strict;
4767use warnings FATAL => 'all';
4768use English qw(-no_match_vars);
4769use constant PTDEBUG => $ENV{PTDEBUG} || 0;
4770
4771use Data::Dumper;
4772$Data::Dumper::Indent = 1;
4773$Data::Dumper::Sortkeys = 1;
4774$Data::Dumper::Quotekeys = 0;
4775
4776my $log_line_regex = qr{
4777 (LOG|DEBUG|CONTEXT|WARNING|ERROR|FATAL|PANIC|HINT
4778 |DETAIL|NOTICE|STATEMENT|INFO|LOCATION)
4779 :\s\s+
4780 }x;
4781
4782my %attrib_name_for = (
4783 u => 'user',
4784 d => 'db',
4785 r => 'host', # With port
4786 h => 'host',
4787 p => 'Process_id',
4788 t => 'ts',
4789 m => 'ts', # With milliseconds
4790 i => 'Query_type',
4791 c => 'Session_id',
4792 l => 'Line_no',
4793 s => 'Session_id',
4794 v => 'Vrt_trx_id',
4795 x => 'Trx_id',
4796);
4797
4798sub new {
4799 my ( $class ) = @_;
4800 my $self = {
4801 pending => [],
4802 is_syslog => undef,
4803 next_event => undef,
4804 'tell' => undef,
4805 };
4806 return bless $self, $class;
4807}
4808
4809sub parse_event {
4810 my ( $self, %args ) = @_;
4811 my @required_args = qw(next_event tell);
4812 foreach my $arg ( @required_args ) {
4813 die "I need a $arg argument" unless $args{$arg};
4814 }
4815
4816 my ( $next_event, $tell, $is_syslog ) = $self->generate_wrappers(%args);
4817
4818 my @properties = ();
4819
4820 my ($pos_in_log, $line, $was_pending) = $self->get_line();
4821 my $new_pos;
4822
4823 my @arg_lines;
4824
4825 my $done;
4826
4827 my $got_duration;
4828
4829 if ( !$was_pending && (!defined $line || $line !~ m/$log_line_regex/o) ) {
4830 PTDEBUG && _d('Skipping lines until I find a header');
4831 my $found_header;
4832 LINE:
4833 while (
4834 eval {
4835 ($new_pos, $line) = $self->get_line();
4836 defined $line;
4837 }
4838 ) {
4839 if ( $line =~ m/$log_line_regex/o ) {
4840 $pos_in_log = $new_pos;
4841 last LINE;
4842 }
4843 else {
4844 PTDEBUG && _d('Line was not a header, will fetch another');
4845 }
4846 }
4847 PTDEBUG && _d('Found a header line, now at pos_in_line', $pos_in_log);
4848 }
4849
4850 my $first_line;
4851
4852 my $line_type;
4853
4854 LINE:
4855 while ( !$done && defined $line ) {
4856
4857 chomp $line unless $is_syslog;
4858
4859 if ( (($line_type) = $line =~ m/$log_line_regex/o) && $line_type ne 'LOG' ) {
4860
4861 if ( @arg_lines ) {
4862 PTDEBUG && _d('Found a non-LOG line, exiting loop');
4863 last LINE;
4864 }
4865
4866 else {
4867 $first_line ||= $line;
4868
4869 if ( my ($e) = $line =~ m/ERROR:\s+(\S.*)\Z/s ) {
4870 push @properties, 'Error_msg', $e;
4871 PTDEBUG && _d('Found an error msg, saving and continuing');
4872 ($new_pos, $line) = $self->get_line();
4873 next LINE;
4874 }
4875
4876 elsif ( my ($s) = $line =~ m/STATEMENT:\s+(\S.*)\Z/s ) {
4877 push @properties, 'arg', $s, 'cmd', 'Query';
4878 PTDEBUG && _d('Found a statement, finishing up event');
4879 $done = 1;
4880 last LINE;
4881 }
4882
4883 else {
4884 PTDEBUG && _d("I don't know what to do with this line");
4885 }
4886 }
4887
4888 }
4889
4890 if (
4891 $line =~ m{
4892 Address\sfamily\snot\ssupported\sby\sprotocol
4893 |archived\stransaction\slog\sfile
4894 |autovacuum:\sprocessing\sdatabase
4895 |checkpoint\srecord\sis\sat
4896 |checkpoints\sare\soccurring\stoo\sfrequently\s\(
4897 |could\snot\sreceive\sdata\sfrom\sclient
4898 |database\ssystem\sis\sready
4899 |database\ssystem\sis\sshut\sdown
4900 |database\ssystem\swas\sshut\sdown
4901 |incomplete\sstartup\spacket
4902 |invalid\slength\sof\sstartup\spacket
4903 |next\sMultiXactId:
4904 |next\stransaction\sID:
4905 |received\ssmart\sshutdown\srequest
4906 |recycled\stransaction\slog\sfile
4907 |redo\srecord\sis\sat
4908 |removing\sfile\s"
4909 |removing\stransaction\slog\sfile\s"
4910 |shutting\sdown
4911 |transaction\sID\swrap\slimit\sis
4912 }x
4913 ) {
4914 PTDEBUG && _d('Skipping this line because it matches skip-pattern');
4915 ($new_pos, $line) = $self->get_line();
4916 next LINE;
4917 }
4918
4919 $first_line ||= $line;
4920
4921 if ( $line !~ m/$log_line_regex/o && @arg_lines ) {
4922
4923 if ( !$is_syslog ) {
4924 $line =~ s/\A\t?/\n/;
4925 }
4926
4927 push @arg_lines, $line;
4928 PTDEBUG && _d('This was a continuation line');
4929 }
4930
4931 elsif (
4932 my ( $sev, $label, $rest )
4933 = $line =~ m/$log_line_regex(.+?):\s+(.*)\Z/so
4934 ) {
4935 PTDEBUG && _d('Line is case 1 or case 3');
4936
4937 if ( @arg_lines ) {
4938 $done = 1;
4939 PTDEBUG && _d('There are saved @arg_lines, we are done');
4940
4941 if ( $label eq 'duration' && $rest =~ m/[0-9.]+\s+\S+\Z/ ) {
4942 if ( $got_duration ) {
4943 PTDEBUG && _d('Discarding line, duration already found');
4944 }
4945 else {
4946 push @properties, 'Query_time', $self->duration_to_secs($rest);
4947 PTDEBUG && _d("Line's duration is for previous event:", $rest);
4948 }
4949 }
4950 else {
4951 $self->pending($new_pos, $line);
4952 PTDEBUG && _d('Deferred line');
4953 }
4954 }
4955
4956 elsif ( $label =~ m/\A(?:duration|statement|query)\Z/ ) {
4957 PTDEBUG && _d('Case 1: start a multi-line event');
4958
4959 if ( $label eq 'duration' ) {
4960
4961 if (
4962 (my ($dur, $stmt)
4963 = $rest =~ m/([0-9.]+ \S+)\s+(?:statement|query): *(.*)\Z/s)
4964 ) {
4965 push @properties, 'Query_time', $self->duration_to_secs($dur);
4966 $got_duration = 1;
4967 push @arg_lines, $stmt;
4968 PTDEBUG && _d('Duration + statement');
4969 }
4970
4971 else {
4972 $first_line = undef;
4973 ($pos_in_log, $line) = $self->get_line();
4974 PTDEBUG && _d('Line applies to event we never saw, discarding');
4975 next LINE;
4976 }
4977 }
4978 else {
4979 push @arg_lines, $rest;
4980 PTDEBUG && _d('Putting onto @arg_lines');
4981 }
4982 }
4983
4984 else {
4985 $done = 1;
4986 PTDEBUG && _d('Line is case 3, event is done');
4987
4988 if ( @arg_lines ) {
4989 $self->pending($new_pos, $line);
4990 PTDEBUG && _d('There was @arg_lines, putting line to pending');
4991 }
4992
4993 else {
4994 PTDEBUG && _d('No need to defer, process event from this line now');
4995 push @properties, 'cmd', 'Admin', 'arg', $label;
4996
4997 if ( $label =~ m/\A(?:dis)?connection(?: received| authorized)?\Z/ ) {
4998 push @properties, $self->get_meta($rest);
4999 }
5000
5001 else {
5002 die "I don't understand line $line";
5003 }
5004
5005 }
5006 }
5007
5008 }
5009
5010 else {
5011 die "I don't understand line $line";
5012 }
5013
5014 if ( !$done ) {
5015 ($new_pos, $line) = $self->get_line();
5016 }
5017 } # LINE
5018
5019 if ( !defined $line ) {
5020 PTDEBUG && _d('Line not defined, at EOF; calling oktorun(0) if exists');
5021 $args{oktorun}->(0) if $args{oktorun};
5022 if ( !@arg_lines ) {
5023 PTDEBUG && _d('No saved @arg_lines either, we are all done');
5024 return undef;
5025 }
5026 }
5027
5028 if ( $line_type && $line_type ne 'LOG' ) {
5029 PTDEBUG && _d('Line is not a LOG line');
5030
5031 if ( $line_type eq 'ERROR' ) {
5032 PTDEBUG && _d('Line is ERROR');
5033
5034 if ( @arg_lines ) {
5035 PTDEBUG && _d('There is @arg_lines, will peek ahead one line');
5036 my ( $temp_pos, $temp_line ) = $self->get_line();
5037 my ( $type, $msg );
5038 if (
5039 defined $temp_line
5040 && ( ($type, $msg) = $temp_line =~ m/$log_line_regex(.*)/o )
5041 && ( $type ne 'STATEMENT' || $msg eq $arg_lines[-1] )
5042 ) {
5043 PTDEBUG && _d('Error/statement line pertain to current event');
5044 push @properties, 'Error_msg', $line =~ m/ERROR:\s*(\S.*)\Z/s;
5045 if ( $type ne 'STATEMENT' ) {
5046 PTDEBUG && _d('Must save peeked line, it is a', $type);
5047 $self->pending($temp_pos, $temp_line);
5048 }
5049 }
5050 elsif ( defined $temp_line && defined $type ) {
5051 PTDEBUG && _d('Error/statement line are a new event');
5052 $self->pending($new_pos, $line);
5053 $self->pending($temp_pos, $temp_line);
5054 }
5055 else {
5056 PTDEBUG && _d("Unknown line", $line);
5057 }
5058 }
5059 }
5060 else {
5061 PTDEBUG && _d("Unknown line", $line);
5062 }
5063 }
5064
5065 if ( $done || @arg_lines ) {
5066 PTDEBUG && _d('Making event');
5067
5068 push @properties, 'pos_in_log', $pos_in_log;
5069
5070 if ( @arg_lines ) {
5071 PTDEBUG && _d('Assembling @arg_lines: ', scalar @arg_lines);
5072 push @properties, 'arg', join('', @arg_lines), 'cmd', 'Query';
5073 }
5074
5075 if ( $first_line ) {
5076 if ( my ($ts) = $first_line =~ m/([0-9-]{10} [0-9:.]{8,12})/ ) {
5077 PTDEBUG && _d('Getting timestamp', $ts);
5078 push @properties, 'ts', $ts;
5079 }
5080
5081 if ( my ($meta) = $first_line =~ m/(.*?)[A-Z]{3,}: / ) {
5082 PTDEBUG && _d('Found a meta-data chunk:', $meta);
5083 push @properties, $self->get_meta($meta);
5084 }
5085 }
5086
5087 PTDEBUG && _d('Properties of event:', Dumper(\@properties));
5088 my $event = { @properties };
5089 $event->{bytes} = length($event->{arg} || '');
5090 return $event;
5091 }
5092
5093}
5094
5095sub get_meta {
5096 my ( $self, $meta ) = @_;
5097 my @properties;
5098 foreach my $set ( $meta =~ m/(\w+=[^, ]+)/g ) {
5099 my ($key, $val) = split(/=/, $set);
5100 if ( $key && $val ) {
5101 if ( my $prop = $attrib_name_for{lc substr($key, 0, 1)} ) {
5102 push @properties, $prop, $val;
5103 }
5104 else {
5105 PTDEBUG && _d('Bad meta key', $set);
5106 }
5107 }
5108 else {
5109 PTDEBUG && _d("Can't figure out meta from", $set);
5110 }
5111 }
5112 return @properties;
5113}
5114
5115sub get_line {
5116 my ( $self ) = @_;
5117 my ($pos, $line, $was_pending) = $self->pending;
5118 if ( ! defined $line ) {
5119 PTDEBUG && _d('Got nothing from pending, trying the $fh');
5120 my ( $next_event, $tell) = @{$self}{qw(next_event tell)};
5121 eval {
5122 $pos = $tell->();
5123 $line = $next_event->();
5124 };
5125 if ( PTDEBUG && $EVAL_ERROR ) {
5126 _d($EVAL_ERROR);
5127 }
5128 }
5129
5130 PTDEBUG && _d('Got pos/line:', $pos, $line);
5131 return ($pos, $line);
5132}
5133
5134sub pending {
5135 my ( $self, $val, $pos_in_log ) = @_;
5136 my $was_pending;
5137 PTDEBUG && _d('In sub pending, val:', $val);
5138 if ( $val ) {
5139 push @{$self->{pending}}, [$val, $pos_in_log];
5140 }
5141 elsif ( @{$self->{pending}} ) {
5142 ($val, $pos_in_log) = @{ shift @{$self->{pending}} };
5143 $was_pending = 1;
5144 }
5145 PTDEBUG && _d('Return from pending:', $val, $pos_in_log);
5146 return ($val, $pos_in_log, $was_pending);
5147}
5148
5149sub generate_wrappers {
5150 my ( $self, %args ) = @_;
5151
5152 if ( ($self->{sanity} || '') ne "$args{next_event}" ){
5153 PTDEBUG && _d("Clearing and recreating internal state");
5154 eval { require SysLogParser; }; # Required for tests to work.
5155 my $sl = new SysLogParser();
5156
5157 $args{misc}->{new_event_test} = sub {
5158 my ( $content ) = @_;
5159 return unless defined $content;
5160 return $content =~ m/$log_line_regex/o;
5161 };
5162
5163 $args{misc}->{line_filter} = sub {
5164 my ( $content ) = @_;
5165 $content =~ s/\A\t/\n/;
5166 return $content;
5167 };
5168
5169 @{$self}{qw(next_event tell is_syslog)} = $sl->make_closures(%args);
5170 $self->{sanity} = "$args{next_event}";
5171 }
5172
5173 return @{$self}{qw(next_event tell is_syslog)};
5174}
5175
5176sub duration_to_secs {
5177 my ( $self, $str ) = @_;
5178 PTDEBUG && _d('Duration:', $str);
5179 my ( $num, $suf ) = split(/\s+/, $str);
5180 my $factor = $suf eq 'ms' ? 1000
5181 : $suf eq 'sec' ? 1
5182 : die("Unknown suffix '$suf'");
5183 return $num / $factor;
5184}
5185
5186sub _d {
5187 my ($package, undef, $line) = caller 0;
5188 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
5189 map { defined $_ ? $_ : 'undef' }
5190 @_;
5191 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
5192}
5193
51941;
5195}
5196# ###########################################################################
5197# End PgLogParser package
5198# ###########################################################################
5199
5200# ###########################################################################
5201# SlowLogParser package4582# SlowLogParser package
5202# This package is a copy without comments from the original. The original4583# This package is a copy without comments from the original. The original
5203# with comments and its test file can be found in the Bazaar repository at,4584# with comments and its test file can be found in the Bazaar repository at,
@@ -7197,9 +6578,7 @@
7197 }6578 }
71986579
7199 my $log_type = $args{log_type} || '';6580 my $log_type = $args{log_type} || '';
7200 my $mark = $log_type eq 'memcached'6581 my $mark = '\G';
7201 || $log_type eq 'http'
7202 || $log_type eq 'pglog' ? '' : '\G';
72036582
7204 if ( $item =~ m/^(?:[\(\s]*select|insert|replace)/ ) {6583 if ( $item =~ m/^(?:[\(\s]*select|insert|replace)/ ) {
7205 if ( $item =~ m/^(?:insert|replace)/ ) { # No EXPLAIN6584 if ( $item =~ m/^(?:insert|replace)/ ) { # No EXPLAIN
@@ -9453,522 +8832,6 @@
9453# ###########################################################################8832# ###########################################################################
94548833
9455# ###########################################################################8834# ###########################################################################
9456# MemcachedProtocolParser package
9457# This package is a copy without comments from the original. The original
9458# with comments and its test file can be found in the Bazaar repository at,
9459# lib/MemcachedProtocolParser.pm
9460# t/lib/MemcachedProtocolParser.t
9461# See https://launchpad.net/percona-toolkit for more information.
9462# ###########################################################################
9463{
9464package MemcachedProtocolParser;
9465
9466use strict;
9467use warnings FATAL => 'all';
9468use English qw(-no_match_vars);
9469
9470use Data::Dumper;
9471$Data::Dumper::Indent = 1;
9472$Data::Dumper::Sortkeys = 1;
9473$Data::Dumper::Quotekeys = 0;
9474
9475use constant PTDEBUG => $ENV{PTDEBUG} || 0;
9476
9477sub new {
9478 my ( $class, %args ) = @_;
9479
9480 my $self = {
9481 server => $args{server},
9482 port => $args{port} || '11211',
9483 sessions => {},
9484 o => $args{o},
9485 };
9486 return bless $self, $class;
9487}
9488
9489sub parse_event {
9490 my ( $self, %args ) = @_;
9491 my @required_args = qw(event);
9492 foreach my $arg ( @required_args ) {
9493 die "I need a $arg argument" unless $args{$arg};
9494 }
9495 my $packet = @args{@required_args};
9496
9497 if ( $packet->{data_len} == 0 ) {
9498 PTDEBUG && _d('No TCP data');
9499 $args{stats}->{no_tcp_data}++ if $args{stats};
9500 return;
9501 }
9502
9503 my $src_host = "$packet->{src_host}:$packet->{src_port}";
9504 my $dst_host = "$packet->{dst_host}:$packet->{dst_port}";
9505
9506 if ( my $server = $self->{server} ) { # Watch only the given server.
9507 $server .= ":$self->{port}";
9508 if ( $src_host ne $server && $dst_host ne $server ) {
9509 PTDEBUG && _d('Packet is not to or from', $server);
9510 $args{stats}->{not_watched_server}++ if $args{stats};
9511 return;
9512 }
9513 }
9514
9515 my $packet_from;
9516 my $client;
9517 if ( $src_host =~ m/:$self->{port}$/ ) {
9518 $packet_from = 'server';
9519 $client = $dst_host;
9520 }
9521 elsif ( $dst_host =~ m/:$self->{port}$/ ) {
9522 $packet_from = 'client';
9523 $client = $src_host;
9524 }
9525 else {
9526 warn 'Packet is not to or from memcached server: ', Dumper($packet);
9527 return;
9528 }
9529 PTDEBUG && _d('Client:', $client);
9530
9531 if ( !exists $self->{sessions}->{$client} ) {
9532 PTDEBUG && _d('New session');
9533 $self->{sessions}->{$client} = {
9534 client => $client,
9535 state => undef,
9536 raw_packets => [],
9537 };
9538 };
9539 my $session = $self->{sessions}->{$client};
9540
9541 push @{$session->{raw_packets}}, $packet->{raw_packet};
9542
9543 $packet->{data} = pack('H*', $packet->{data});
9544 my $event;
9545 if ( $packet_from eq 'server' ) {
9546 $event = $self->_packet_from_server($packet, $session, %args);
9547 }
9548 elsif ( $packet_from eq 'client' ) {
9549 $event = $self->_packet_from_client($packet, $session, %args);
9550 }
9551 else {
9552 $args{stats}->{unknown_packet_origin}++ if $args{stats};
9553 die 'Packet origin unknown';
9554 }
9555
9556 PTDEBUG && _d('Done with packet; event:', Dumper($event));
9557 $args{stats}->{events_parsed}++ if $args{stats};
9558 return $event;
9559}
9560
9561sub _packet_from_server {
9562 my ( $self, $packet, $session, %args ) = @_;
9563 die "I need a packet" unless $packet;
9564 die "I need a session" unless $session;
9565
9566 PTDEBUG && _d('Packet is from server; client state:', $session->{state});
9567
9568 my $data = $packet->{data};
9569
9570 if ( !$session->{state} ) {
9571 PTDEBUG && _d('Ignoring mid-stream server response');
9572 $args{stats}->{ignored_midstream_server_response}++ if $args{stats};
9573 return;
9574 }
9575
9576 if ( $session->{state} eq 'awaiting reply' ) {
9577 PTDEBUG && _d('State is awaiting reply');
9578 my ($line1, $rest) = $packet->{data} =~ m/\A(.*?)\r\n(.*)?/s;
9579 if ( !$line1 ) {
9580 $args{stats}->{unknown_server_data}++ if $args{stats};
9581 die "Unknown memcached data from server";
9582 }
9583
9584 my @vals = $line1 =~ m/(\S+)/g;
9585 $session->{res} = shift @vals;
9586 PTDEBUG && _d('Result of last', $session->{cmd}, 'cmd:', $session->{res});
9587
9588 if ( $session->{cmd} eq 'incr' || $session->{cmd} eq 'decr' ) {
9589 PTDEBUG && _d('It is an incr or decr');
9590 if ( $session->{res} !~ m/\D/ ) { # It's an integer, not an error
9591 PTDEBUG && _d('Got a value for the incr/decr');
9592 $session->{val} = $session->{res};
9593 $session->{res} = '';
9594 }
9595 }
9596 elsif ( $session->{res} eq 'VALUE' ) {
9597 PTDEBUG && _d('It is the result of a "get"');
9598 my ($key, $flags, $bytes) = @vals;
9599 defined $session->{flags} or $session->{flags} = $flags;
9600 defined $session->{bytes} or $session->{bytes} = $bytes;
9601
9602 if ( $rest && $bytes ) {
9603 PTDEBUG && _d('There is a value');
9604 if ( length($rest) > $bytes ) {
9605 PTDEBUG && _d('Got complete response');
9606 $session->{val} = substr($rest, 0, $bytes);
9607 }
9608 else {
9609 PTDEBUG && _d('Got partial response, saving for later');
9610 push @{$session->{partial}}, [ $packet->{seq}, $rest ];
9611 $session->{gathered} += length($rest);
9612 $session->{state} = 'partial recv';
9613 return; # Prevent firing an event.
9614 }
9615 }
9616 }
9617 elsif ( $session->{res} eq 'END' ) {
9618 PTDEBUG && _d('Got an END without any data, firing NOT_FOUND');
9619 $session->{res} = 'NOT_FOUND';
9620 }
9621 elsif ( $session->{res} !~ m/STORED|DELETED|NOT_FOUND/ ) {
9622 PTDEBUG && _d('Unknown result');
9623 }
9624 else {
9625 $args{stats}->{unknown_server_response}++ if $args{stats};
9626 }
9627 }
9628 else { # Should be 'partial recv'
9629 PTDEBUG && _d('Session state: ', $session->{state});
9630 push @{$session->{partial}}, [ $packet->{seq}, $data ];
9631 $session->{gathered} += length($data);
9632 PTDEBUG && _d('Gathered', $session->{gathered}, 'bytes in',
9633 scalar(@{$session->{partial}}), 'packets from server');
9634 if ( $session->{gathered} >= $session->{bytes} + 2 ) { # Done.
9635 PTDEBUG && _d('End of partial response, preparing event');
9636 my $val = join('',
9637 map { $_->[1] }
9638 sort { $a->[0] <=> $b->[0] }
9639 @{$session->{partial}});
9640 $session->{val} = substr($val, 0, $session->{bytes});
9641 }
9642 else {
9643 PTDEBUG && _d('Partial response continues, no action');
9644 return; # Prevent firing event.
9645 }
9646 }
9647
9648 PTDEBUG && _d('Creating event, deleting session');
9649 my $event = make_event($session, $packet);
9650 delete $self->{sessions}->{$session->{client}}; # memcached is stateless!
9651 $session->{raw_packets} = []; # Avoid keeping forever
9652 return $event;
9653}
9654
9655sub _packet_from_client {
9656 my ( $self, $packet, $session, %args ) = @_;
9657 die "I need a packet" unless $packet;
9658 die "I need a session" unless $session;
9659
9660 PTDEBUG && _d('Packet is from client; state:', $session->{state});
9661
9662 my $event;
9663 if ( ($session->{state} || '') =~m/awaiting reply|partial recv/ ) {
9664 PTDEBUG && _d("Expected data from the client, looks like interrupted");
9665 $session->{res} = 'INTERRUPTED';
9666 $event = make_event($session, $packet);
9667 my $client = $session->{client};
9668 delete @{$session}{keys %$session};
9669 $session->{client} = $client;
9670 }
9671
9672 my ($line1, $val);
9673 my ($cmd, $key, $flags, $exptime, $bytes);
9674
9675 if ( !$session->{state} ) {
9676 PTDEBUG && _d('Session state: ', $session->{state});
9677 ($line1, $val) = $packet->{data} =~ m/\A(.*?)\r\n(.+)?/s;
9678 if ( !$line1 ) {
9679 PTDEBUG && _d('Unknown memcached data from client, skipping packet');
9680 $args{stats}->{unknown_client_data}++ if $args{stats};
9681 return;
9682 }
9683
9684 my @vals = $line1 =~ m/(\S+)/g;
9685 $cmd = lc shift @vals;
9686 PTDEBUG && _d('$cmd is a ', $cmd);
9687 if ( $cmd eq 'set' || $cmd eq 'add' || $cmd eq 'replace' ) {
9688 ($key, $flags, $exptime, $bytes) = @vals;
9689 $session->{bytes} = $bytes;
9690 }
9691 elsif ( $cmd eq 'get' ) {
9692 ($key) = @vals;
9693 if ( $val ) {
9694 PTDEBUG && _d('Multiple cmds:', $val);
9695 $val = undef;
9696 }
9697 }
9698 elsif ( $cmd eq 'delete' ) {
9699 ($key) = @vals; # TODO: handle the <queue_time>
9700 if ( $val ) {
9701 PTDEBUG && _d('Multiple cmds:', $val);
9702 $val = undef;
9703 }
9704 }
9705 elsif ( $cmd eq 'incr' || $cmd eq 'decr' ) {
9706 ($key) = @vals;
9707 }
9708 else {
9709 PTDEBUG && _d("Don't know how to handle", $cmd, "command");
9710 $args{stats}->{unknown_client_command}++ if $args{stats};
9711 return;
9712 }
9713
9714 @{$session}{qw(cmd key flags exptime)}
9715 = ($cmd, $key, $flags, $exptime);
9716 $session->{host} = $packet->{src_host};
9717 $session->{pos_in_log} = $packet->{pos_in_log};
9718 $session->{ts} = $packet->{ts};
9719 }
9720 else {
9721 PTDEBUG && _d('Session state: ', $session->{state});
9722 $val = $packet->{data};
9723 }
9724
9725 $session->{state} = 'awaiting reply'; # Assume we got the whole packet
9726 if ( $val ) {
9727 if ( $session->{bytes} + 2 == length($val) ) { # +2 for the \r\n
9728 PTDEBUG && _d('Complete send');
9729 $val =~ s/\r\n\Z//; # We got the whole thing.
9730 $session->{val} = $val;
9731 }
9732 else { # We apparently did NOT get the whole thing.
9733 PTDEBUG && _d('Partial send, saving for later');
9734 push @{$session->{partial}},
9735 [ $packet->{seq}, $val ];
9736 $session->{gathered} += length($val);
9737 PTDEBUG && _d('Gathered', $session->{gathered}, 'bytes in',
9738 scalar(@{$session->{partial}}), 'packets from client');
9739 if ( $session->{gathered} >= $session->{bytes} + 2 ) { # Done.
9740 PTDEBUG && _d('Message looks complete now, saving value');
9741 $val = join('',
9742 map { $_->[1] }
9743 sort { $a->[0] <=> $b->[0] }
9744 @{$session->{partial}});
9745 $val =~ s/\r\n\Z//;
9746 $session->{val} = $val;
9747 }
9748 else {
9749 PTDEBUG && _d('Message not complete');
9750 $val = '[INCOMPLETE]';
9751 $session->{state} = 'partial send';
9752 }
9753 }
9754 }
9755
9756 return $event;
9757}
9758
9759sub make_event {
9760 my ( $session, $packet ) = @_;
9761 my $event = {
9762 cmd => $session->{cmd},
9763 key => $session->{key},
9764 val => $session->{val} || '',
9765 res => $session->{res},
9766 ts => $session->{ts},
9767 host => $session->{host},
9768 flags => $session->{flags} || 0,
9769 exptime => $session->{exptime} || 0,
9770 bytes => $session->{bytes} || 0,
9771 Query_time => timestamp_diff($session->{ts}, $packet->{ts}),
9772 pos_in_log => $session->{pos_in_log},
9773 };
9774 return $event;
9775}
9776
9777sub _get_errors_fh {
9778 my ( $self ) = @_;
9779 my $errors_fh = $self->{errors_fh};
9780 return $errors_fh if $errors_fh;
9781
9782 my $o = $self->{o};
9783 if ( $o && $o->has('tcpdump-errors') && $o->got('tcpdump-errors') ) {
9784 my $errors_file = $o->get('tcpdump-errors');
9785 PTDEBUG && _d('tcpdump-errors file:', $errors_file);
9786 open $errors_fh, '>>', $errors_file
9787 or die "Cannot open tcpdump-errors file $errors_file: $OS_ERROR";
9788 }
9789
9790 $self->{errors_fh} = $errors_fh;
9791 return $errors_fh;
9792}
9793
9794sub _d {
9795 my ($package, undef, $line) = caller 0;
9796 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
9797 map { defined $_ ? $_ : 'undef' }
9798 @_;
9799 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
9800}
9801
9802sub timestamp_diff {
9803 my ( $start, $end ) = @_;
9804 my $sd = substr($start, 0, 11, '');
9805 my $ed = substr($end, 0, 11, '');
9806 my ( $sh, $sm, $ss ) = split(/:/, $start);
9807 my ( $eh, $em, $es ) = split(/:/, $end);
9808 my $esecs = ($eh * 3600 + $em * 60 + $es);
9809 my $ssecs = ($sh * 3600 + $sm * 60 + $ss);
9810 if ( $sd eq $ed ) {
9811 return sprintf '%.6f', $esecs - $ssecs;
9812 }
9813 else { # Assume only one day boundary has been crossed, no DST, etc
9814 return sprintf '%.6f', ( 86_400 - $ssecs ) + $esecs;
9815 }
9816}
9817
98181;
9819}
9820# ###########################################################################
9821# End MemcachedProtocolParser package
9822# ###########################################################################
9823
9824# ###########################################################################
9825# MemcachedEvent package
9826# This package is a copy without comments from the original. The original
9827# with comments and its test file can be found in the Bazaar repository at,
9828# lib/MemcachedEvent.pm
9829# t/lib/MemcachedEvent.t
9830# See https://launchpad.net/percona-toolkit for more information.
9831# ###########################################################################
9832{
9833package MemcachedEvent;
9834
9835use strict;
9836use warnings FATAL => 'all';
9837use English qw(-no_match_vars);
9838use constant PTDEBUG => $ENV{PTDEBUG} || 0;
9839
9840use Data::Dumper;
9841$Data::Dumper::Indent = 1;
9842$Data::Dumper::Sortkeys = 1;
9843$Data::Dumper::Quotekeys = 0;
9844
9845my %cmds = map { $_ => 1 } qw(
9846 set
9847 add
9848 replace
9849 append
9850 prepend
9851 cas
9852 get
9853 gets
9854 delete
9855 incr
9856 decr
9857);
9858
9859my %cmd_handler_for = (
9860 set => \&handle_storage_cmd,
9861 add => \&handle_storage_cmd,
9862 replace => \&handle_storage_cmd,
9863 append => \&handle_storage_cmd,
9864 prepend => \&handle_storage_cmd,
9865 cas => \&handle_storage_cmd,
9866 get => \&handle_retr_cmd,
9867 gets => \&handle_retr_cmd,
9868);
9869
9870sub new {
9871 my ( $class, %args ) = @_;
9872 my $self = {};
9873 return bless $self, $class;
9874}
9875
9876sub parse_event {
9877 my ( $self, %args ) = @_;
9878 my $event = $args{event};
9879 return unless $event;
9880
9881 if ( !$event->{cmd} || !$event->{key} ) {
9882 PTDEBUG && _d('Event has no cmd or key:', Dumper($event));
9883 return;
9884 }
9885
9886 if ( !$cmds{$event->{cmd}} ) {
9887 PTDEBUG && _d("Don't know how to handle cmd:", $event->{cmd});
9888 return;
9889 }
9890
9891 $event->{arg} = "$event->{cmd} $event->{key}";
9892 $event->{fingerprint} = $self->fingerprint($event->{arg});
9893 $event->{key_print} = $self->fingerprint($event->{key});
9894
9895 map { $event->{"Memc_$_"} = 'No' } keys %cmds;
9896 $event->{"Memc_$event->{cmd}"} = 'Yes'; # Got this cmd.
9897 $event->{Memc_error} = 'No'; # A handler may change this.
9898 $event->{Memc_miss} = 'No';
9899 if ( $event->{res} ) {
9900 $event->{Memc_miss} = 'Yes' if $event->{res} eq 'NOT_FOUND';
9901 }
9902 else {
9903 PTDEBUG && _d('Event has no res:', Dumper($event));
9904 }
9905
9906 if ( $cmd_handler_for{$event->{cmd}} ) {
9907 return $cmd_handler_for{$event->{cmd}}->($event);
9908 }
9909
9910 return $event;
9911}
9912
9913sub fingerprint {
9914 my ( $self, $val ) = @_;
9915 $val =~ s/[0-9A-Fa-f]{16,}|\d+/?/g;
9916 return $val;
9917}
9918
9919sub handle_storage_cmd {
9920 my ( $event ) = @_;
9921
9922 if ( !$event->{res} ) {
9923 PTDEBUG && _d('No result for event:', Dumper($event));
9924 return;
9925 }
9926
9927 $event->{'Memc_Not_Stored'} = $event->{res} eq 'NOT_STORED' ? 'Yes' : 'No';
9928 $event->{'Memc_Exists'} = $event->{res} eq 'EXISTS' ? 'Yes' : 'No';
9929
9930 return $event;
9931}
9932
9933sub handle_retr_cmd {
9934 my ( $event ) = @_;
9935
9936 if ( !$event->{res} ) {
9937 PTDEBUG && _d('No result for event:', Dumper($event));
9938 return;
9939 }
9940
9941 $event->{'Memc_error'} = $event->{res} eq 'INTERRUPTED' ? 'Yes' : 'No';
9942
9943 return $event;
9944}
9945
9946
9947sub handle_delete {
9948 my ( $event ) = @_;
9949 return $event;
9950}
9951
9952sub handle_incr_decr_cmd {
9953 my ( $event ) = @_;
9954 return $event;
9955}
9956
9957sub _d {
9958 my ($package, undef, $line) = caller 0;
9959 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
9960 map { defined $_ ? $_ : 'undef' }
9961 @_;
9962 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
9963}
9964
99651;
9966}
9967# ###########################################################################
9968# End MemcachedEvent package
9969# ###########################################################################
9970
9971# ###########################################################################
9972# BinaryLogParser package8835# BinaryLogParser package
9973# This package is a copy without comments from the original. The original8836# This package is a copy without comments from the original. The original
9974# with comments and its test file can be found in the Bazaar repository at,8837# with comments and its test file can be found in the Bazaar repository at,
@@ -10719,209 +9582,6 @@
10719# ###########################################################################9582# ###########################################################################
107209583
10721# ###########################################################################9584# ###########################################################################
10722# HTTPProtocolParser package
10723# This package is a copy without comments from the original. The original
10724# with comments and its test file can be found in the Bazaar repository at,
10725# lib/HTTPProtocolParser.pm
10726# t/lib/HTTPProtocolParser.t
10727# See https://launchpad.net/percona-toolkit for more information.
10728# ###########################################################################
10729{
10730package HTTPProtocolParser;
10731use base 'ProtocolParser';
10732
10733use strict;
10734use warnings FATAL => 'all';
10735use English qw(-no_match_vars);
10736use constant PTDEBUG => $ENV{PTDEBUG} || 0;
10737
10738sub new {
10739 my ( $class, %args ) = @_;
10740 my $self = $class->SUPER::new(
10741 %args,
10742 port => 80,
10743 );
10744 return $self;
10745}
10746
10747sub _packet_from_server {
10748 my ( $self, $packet, $session, $misc ) = @_;
10749 die "I need a packet" unless $packet;
10750 die "I need a session" unless $session;
10751
10752 PTDEBUG && _d('Packet is from server; client state:', $session->{state});
10753
10754 if ( !$session->{state} ) {
10755 PTDEBUG && _d('Ignoring mid-stream server response');
10756 return;
10757 }
10758
10759 if ( $session->{out_of_order} ) {
10760 my ($line1, $content);
10761 if ( !$session->{have_header} ) {
10762 ($line1, $content) = $self->_parse_header(
10763 $session, $packet->{data}, $packet->{data_len});
10764 }
10765 if ( $line1 ) {
10766 $session->{have_header} = 1;
10767 $packet->{content_len} = length $content;
10768 PTDEBUG && _d('Got out of order header with',
10769 $packet->{content_len}, 'bytes of content');
10770 }
10771 my $have_len = $packet->{content_len} || $packet->{data_len};
10772 map { $have_len += $_->{data_len} }
10773 @{$session->{packets}};
10774 $session->{have_all_packets}
10775 = 1 if $session->{attribs}->{bytes}
10776 && $have_len >= $session->{attribs}->{bytes};
10777 PTDEBUG && _d('Have', $have_len, 'of', $session->{attribs}->{bytes});
10778 return;
10779 }
10780
10781 if ( $session->{state} eq 'awaiting reply' ) {
10782
10783 $session->{start_reply} = $packet->{ts} unless $session->{start_reply};
10784
10785 my ($line1, $content) = $self->_parse_header($session, $packet->{data},
10786 $packet->{data_len});
10787
10788 if ( !$line1 ) {
10789 $session->{out_of_order} = 1; # alert parent
10790 $session->{have_all_packets} = 0;
10791 return;
10792 }
10793
10794 my ($version, $code, $phrase) = $line1 =~ m/(\S+)/g;
10795 $session->{attribs}->{Status_code} = $code;
10796 PTDEBUG && _d('Status code for last', $session->{attribs}->{arg},
10797 'request:', $session->{attribs}->{Status_code});
10798
10799 my $content_len = $content ? length $content : 0;
10800 PTDEBUG && _d('Got', $content_len, 'bytes of content');
10801 if ( $session->{attribs}->{bytes}
10802 && $content_len < $session->{attribs}->{bytes} ) {
10803 $session->{data_len} = $session->{attribs}->{bytes};
10804 $session->{buff} = $content;
10805 $session->{buff_left} = $session->{attribs}->{bytes} - $content_len;
10806 PTDEBUG && _d('Contents not complete,', $session->{buff_left},
10807 'bytes left');
10808 $session->{state} = 'recving content';
10809 return;
10810 }
10811 }
10812 elsif ( $session->{state} eq 'recving content' ) {
10813 if ( $session->{buff} ) {
10814 PTDEBUG && _d('Receiving content,', $session->{buff_left},
10815 'bytes left');
10816 return;
10817 }
10818 PTDEBUG && _d('Contents received');
10819 }
10820 else {
10821 warn "Server response in unknown state";
10822 return;
10823 }
10824
10825 PTDEBUG && _d('Creating event, deleting session');
10826 $session->{end_reply} = $session->{ts_max} || $packet->{ts};
10827 my $event = $self->make_event($session, $packet);
10828 delete $self->{sessions}->{$session->{client}}; # http is stateless!
10829 return $event;
10830}
10831
10832sub _packet_from_client {
10833 my ( $self, $packet, $session, $misc ) = @_;
10834 die "I need a packet" unless $packet;
10835 die "I need a session" unless $session;
10836
10837 PTDEBUG && _d('Packet is from client; state:', $session->{state});
10838
10839 my $event;
10840 if ( ($session->{state} || '') =~ m/awaiting / ) {
10841 PTDEBUG && _d('More client headers:', $packet->{data});
10842 return;
10843 }
10844
10845 if ( !$session->{state} ) {
10846 $session->{state} = 'awaiting reply';
10847 my ($line1, undef) = $self->_parse_header($session, $packet->{data}, $packet->{data_len});
10848 my ($request, $page, $version) = $line1 =~ m/(\S+)/g;
10849 if ( !$request || !$page ) {
10850 PTDEBUG && _d("Didn't get a request or page:", $request, $page);
10851 return;
10852 }
10853 $request = lc $request;
10854 my $vh = $session->{attribs}->{Virtual_host} || '';
10855 my $arg = "$request $vh$page";
10856 PTDEBUG && _d('arg:', $arg);
10857
10858 if ( $request eq 'get' || $request eq 'post' ) {
10859 @{$session->{attribs}}{qw(arg)} = ($arg);
10860 }
10861 else {
10862 PTDEBUG && _d("Don't know how to handle a", $request, "request");
10863 return;
10864 }
10865
10866 $session->{start_request} = $packet->{ts};
10867 $session->{attribs}->{host} = $packet->{src_host};
10868 $session->{attribs}->{pos_in_log} = $packet->{pos_in_log};
10869 $session->{attribs}->{ts} = $packet->{ts};
10870 }
10871 else {
10872 die "Probably multiple GETs from client before a server response?";
10873 }
10874
10875 return $event;
10876}
10877
10878sub _parse_header {
10879 my ( $self, $session, $data, $len, $no_recurse ) = @_;
10880 die "I need data" unless $data;
10881 my ($header, $content) = split(/\r\n\r\n/, $data);
10882 my ($line1, $header_vals) = $header =~ m/\A(\S+ \S+ .+?)\r\n(.+)?/s;
10883 PTDEBUG && _d('HTTP header:', $line1);
10884 return unless $line1;
10885
10886 if ( !$header_vals ) {
10887 PTDEBUG && _d('No header vals');
10888 return $line1, undef;
10889 }
10890 my @headers;
10891 foreach my $val ( split(/\r\n/, $header_vals) ) {
10892 last unless $val;
10893 PTDEBUG && _d('HTTP header:', $val);
10894 if ( $val =~ m/^Content-Length/i ) {
10895 ($session->{attribs}->{bytes}) = $val =~ /: (\d+)/;
10896 PTDEBUG && _d('Saved Content-Length:', $session->{attribs}->{bytes});
10897 }
10898 if ( $val =~ m/Content-Encoding/i ) {
10899 ($session->{compressed}) = $val =~ /: (\w+)/;
10900 PTDEBUG && _d('Saved Content-Encoding:', $session->{compressed});
10901 }
10902 if ( $val =~ m/^Host/i ) {
10903 ($session->{attribs}->{Virtual_host}) = $val =~ /: (\S+)/;
10904 PTDEBUG && _d('Saved Host:', ($session->{attribs}->{Virtual_host}));
10905 }
10906 }
10907 return $line1, $content;
10908}
10909
10910sub _d {
10911 my ($package, undef, $line) = caller 0;
10912 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
10913 map { defined $_ ? $_ : 'undef' }
10914 @_;
10915 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
10916}
10917
109181;
10919}
10920# ###########################################################################
10921# End HTTPProtocolParser package
10922# ###########################################################################
10923
10924# ###########################################################################
10925# MasterSlave package9585# MasterSlave package
10926# This package is a copy without comments from the original. The original9586# This package is a copy without comments from the original. The original
10927# with comments and its test file can be found in the Bazaar repository at,9587# with comments and its test file can be found in the Bazaar repository at,
@@ -13986,10 +12646,6 @@
13986 binlog => ['BinaryLogParser'],12646 binlog => ['BinaryLogParser'],
13987 genlog => ['GeneralLogParser'],12647 genlog => ['GeneralLogParser'],
13988 tcpdump => ['TcpdumpParser','MySQLProtocolParser'],12648 tcpdump => ['TcpdumpParser','MySQLProtocolParser'],
13989 memcached => ['TcpdumpParser','MemcachedProtocolParser',
13990 'MemcachedEvent'],
13991 http => ['TcpdumpParser','HTTPProtocolParser'],
13992 pglog => ['PgLogParser'],
13993 rawlog => ['RawLogParser'],12649 rawlog => ['RawLogParser'],
13994 );12650 );
13995 my $type = $o->get('type');12651 my $type = $o->get('type');
@@ -14543,17 +13199,6 @@
1454313199
14544 { # distill13200 { # distill
14545 my %distill_args;13201 my %distill_args;
14546 if ( $o->get('type') eq 'memcached' || $o->get('type') eq 'http' ) {
14547 $distill_args{generic} = 1;
14548 if ( $o->get('type') eq 'http' ) {
14549 # Remove stuff after url.
14550 $distill_args{trf} = sub {
14551 my ( $query ) = @_;
14552 $query =~ s/(\S+ \S+?)(?:[?;].+)/$1/;
14553 return $query;
14554 };
14555 }
14556 }
14557 if ( grep { $_ eq 'distill' } @groupby ) {13202 if ( grep { $_ eq 'distill' } @groupby ) {
14558 $pipeline->add(13203 $pipeline->add(
14559 name => 'distill',13204 name => 'distill',
@@ -15282,7 +13927,7 @@
1528213927
15283=head1 NAME13928=head1 NAME
1528413929
15285pt-query-digest - Analyze query execution logs and generate a query report, filter, replay, or transform queries for MySQL, PostgreSQL, memcached, and more.13930pt-query-digest - Analyze query execution logs and generate a query report, filter, replay, or transform queries for MySQL.
1528613931
15287=head1 SYNOPSIS13932=head1 SYNOPSIS
1528813933
@@ -15387,19 +14032,6 @@
15387Attributes created this way can be specified for L<"--order-by"> or any14032Attributes created this way can be specified for L<"--order-by"> or any
15388option that requires an attribute.14033option that requires an attribute.
1538914034
15390=head2 memcached
15391
15392memcached events have additional attributes related to the memcached protocol:
15393cmd, key, res (result) and val. Also, boolean attributes are created for
15394the various commands, misses and errors: Memc_CMD where CMD is a memcached
15395command (get, set, delete, etc.), Memc_error and Memc_miss.
15396
15397These attributes are no different from slow log attributes, so you can use them
15398with L<"--[no]report">, L<"--group-by">, in a L<"--filter">, etc.
15399
15400See the memcached section of L<"ATTRIBUTES REFERENCE"> for a list of
15401memcached-specific attributes.
15402
15403=head1 OUTPUT14035=head1 OUTPUT
1540414036
15405The default output is a query analysis report. The L<"--[no]report"> option14037The default output is a query analysis report. The L<"--[no]report"> option
@@ -15657,12 +14289,6 @@
15657You can also use the value C<distill>, which is a kind of super-fingerprint.14289You can also use the value C<distill>, which is a kind of super-fingerprint.
15658See L<"--group-by"> for more.14290See L<"--group-by"> for more.
1565914291
15660When parsing memcached input (L<"--type"> memcached), the fingerprint is an
15661abstracted version of the command and key, with placeholders removed. For
15662example, C<get user_123_preferences> fingerprints to C<get user_?_preferences>.
15663There is also a C<key_print> which a fingerprinted version of the key. This
15664example's key_print is C<user_?_preferences>.
15665
15666Query fingerprinting accommodates a great many special cases, which have proven14292Query fingerprinting accommodates a great many special cases, which have proven
15667necessary in the real world. For example, an IN list with 5 literals is really14293necessary in the real world. For example, an IN list with 5 literals is really
15668equivalent to one with 4 literals, so lists of literals are collapsed to a14294equivalent to one with 4 literals, so lists of literals are collapsed to a
@@ -16027,11 +14653,6 @@
1602714653
16028=back14654=back
1602914655
16030If parsing memcached input (L<"--type"> memcached), there are other
16031attributes which you can group by: key_print (see memcached section in
16032L<"FINGERPRINTS">), cmd, key, res and val (see memcached section in
16033L<"ATTRIBUTES">).
16034
16035=item --help14656=item --help
1603614657
16037Show help and exit.14658Show help and exit.
@@ -16761,52 +15382,6 @@
16761notably C<Query_time>. The default L<"--order-by"> for general logs15382notably C<Query_time>. The default L<"--order-by"> for general logs
16762changes to C<Query_time:cnt>.15383changes to C<Query_time:cnt>.
1676315384
16764=item http
16765
16766Parse HTTP traffic from tcpdump.
16767
16768=item pglog
16769
16770Parse a log file in PostgreSQL format. The parser will automatically recognize
16771logs sent to syslog and transparently parse the syslog format, too. The
16772recommended configuration for logging in your postgresql.conf is as follows.
16773
16774The log_destination setting can be set to either syslog or stderr. Syslog has
16775the added benefit of not interleaving log messages from several sessions
16776concurrently, which the parser cannot handle, so this might be better than
16777stderr. CSV-formatted logs are not supported at this time.
16778
16779The log_min_duration_statement setting should be set to 0 to capture all
16780statements with their durations. Alternatively, the parser will also recognize
16781and handle various combinations of log_duration and log_statement.
16782
16783You may enable log_connections and log_disconnections, but this is optional.
16784
16785It is highly recommended to set your log_line_prefix to the following:
16786
16787 log_line_prefix = '%m c=%c,u=%u,D=%d '
16788
16789This lets the parser find timestamps with milliseconds, session IDs, users, and
16790databases from the log. If these items are missing, you'll simply get less
16791information to analyze. For compatibility with other log analysis tools such as
16792PQA and pgfouine, various log line prefix formats are supported. The general
16793format is as follows: a timestamp can be detected and extracted (the syslog
16794timestamp is NOT parsed), and a name=value list of properties can also.
16795Although the suggested format is as shown above, any name=value list will be
16796captured and interpreted by using the first letter of the 'name' part,
16797lowercased, to determine the meaning of the item. The lowercased first letter
16798is interpreted to mean the same thing as PostgreSQL's built-in %-codes for the
16799log_line_prefix format string. For example, u means user, so unicorn=fred
16800will be interpreted as user=fred; d means database, so D=john will be
16801interpreted as database=john. The pgfouine-suggested formatting is user=%u and
16802db=%d, so it should Just Work regardless of which format you choose. The main
16803thing is to add as much information as possible into the log_line_prefix to
16804permit richer analysis.
16805
16806Currently, only English locale messages are supported, so if your server's
16807locale is set to something else, the log won't be parsed properly. (Log
16808messages with "duration:" and "statement:" won't be recognized.)
16809
16810=item slowlog15385=item slowlog
1681115386
16812Parse a log file in any variation of MySQL slow-log format.15387Parse a log file in any variation of MySQL slow-log format.
@@ -16872,17 +15447,6 @@
16872Server-side prepared statements are supported. SSL-encrypted traffic cannot be15447Server-side prepared statements are supported. SSL-encrypted traffic cannot be
16873inspected and decoded.15448inspected and decoded.
1687415449
16875=item memcached
16876
16877Similar to tcpdump, but the expected input is memcached packets
16878instead of MySQL packets. For example:
16879
16880 tcpdump -i any port 11211 -s 65535 -x -nn -q -tttt \
16881 > memcached.tcp.txt
16882 pt-query-digest --type memcached memcached.tcp.txt
16883
16884memcached uses port 11211 by default.
16885
16886=back15450=back
1688715451
16888=item --until15452=item --until
@@ -16962,8 +15526,8 @@
16962type: string15526type: string
1696315527
16964This option tells pt-query-digest which server IP address and port (like15528This option tells pt-query-digest which server IP address and port (like
16965"10.0.0.1:3306") to watch when parsing tcpdump (for L<"--type"> tcpdump and15529"10.0.0.1:3306") to watch when parsing tcpdump (for L<"--type"> tcpdump);
16966memcached); all other servers are ignored. If you don't specify it,15530all other servers are ignored. If you don't specify it,
16967pt-query-digest watches all servers by looking for any IP address using port15531pt-query-digest watches all servers by looking for any IP address using port
169683306 or "mysql". If you're watching a server with a non-standard port, this155323306 or "mysql". If you're watching a server with a non-standard port, this
16969won't work, so you must specify the IP address and port to watch.15533won't work, so you must specify the IP address and port to watch.
@@ -17156,13 +15720,12 @@
1715615720
17157=item cmd15721=item cmd
1715815722
17159"Query" or "Admin" for all except memcached. For memcached it's15723"Query" or "Admin".
17160the memcached command: get, set, etc.
1716115724
17162=item db15725=item db
1716315726
17164The current database, except for memcached. The value comes from USE15727The current database. The value comes from USE database statements.
17165database statements. By default, C<Schema> is an alias which is automatically15728By default, C<Schema> is an alias which is automatically
17166changed to C<db>; see L<"--attribute-aliases">.15729changed to C<db>; see L<"--attribute-aliases">.
1716715730
17168=item fingerprint 15731=item fingerprint
@@ -17235,75 +15798,6 @@
17235If using L<"--processlist">, an C<id> attribute is available for15798If using L<"--processlist">, an C<id> attribute is available for
17236the process ID, in addition to the common attributes.15799the process ID, in addition to the common attributes.
1723715800
17238=head2 MEMCACHED
17239
17240These attributes are available when parsing L<"--type"> memcached.
17241
17242=over
17243
17244=item exptime
17245
17246Expiration time.
17247
17248=item key
17249
17250The key used by cmd.
17251
17252=item key_print
17253
17254An abstracted form of the key.
17255
17256=item Memc_add
17257
17258Yes/No if the command is add.
17259
17260=item Memc_append
17261
17262Yes/No if the command is append.
17263
17264=item Memc_cas
17265
17266Yes/No if the command is cas.
17267
17268=item Memc_error
17269
17270Yes/No if command caused an error. Currently, the only error is when
17271a retrieval command is interrupted.
17272
17273=item Memc_get
17274
17275Yes/No if the command is get.
17276
17277=item Memc_gets
17278
17279Yes/No if the command is gets.
17280
17281=item Memc_miss
17282
17283Yes/No if the command tried to access a nonexistent key.
17284
17285=item Memc_prepend
17286
17287Yes/No if the command is prepend.
17288
17289=item Memc_replace
17290
17291Yes/No if the command is replace.
17292
17293=item Memc_set
17294
17295Yes/No if the command is set.
17296
17297=item res
17298
17299Result of cmd.
17300
17301=item val
17302
17303The return value of cmd, if any.
17304
17305=back
17306
17307=head1 AUTHORS15801=head1 AUTHORS
1730815802
17309Baron Schwartz and Daniel Nichter15803Baron Schwartz and Daniel Nichter
1731015804
=== removed file 'lib/HTTPProtocolParser.pm'
--- lib/HTTPProtocolParser.pm 2013-01-03 00:19:16 +0000
+++ lib/HTTPProtocolParser.pm 1970-01-01 00:00:00 +0000
@@ -1,242 +0,0 @@
1# This program is copyright 2009-2011 Percona Ireland Ltd.
2# Feedback and improvements are welcome.
3#
4# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
5# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
7#
8# This program is free software; you can redistribute it and/or modify it under
9# the terms of the GNU General Public License as published by the Free Software
10# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
11# systems, you can issue `man perlgpl' or `man perlartistic' to read these
12# licenses.
13#
14# You should have received a copy of the GNU General Public License along with
15# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
16# Place, Suite 330, Boston, MA 02111-1307 USA.
17# ###########################################################################
18# HTTPProtocolParser package
19# ###########################################################################
20{
21# Package: HTTPProtocolParser
22# HTTPProtocolParser parses HTTP traffic from tcpdump files.
23package HTTPProtocolParser;
24use base 'ProtocolParser';
25
26use strict;
27use warnings FATAL => 'all';
28use English qw(-no_match_vars);
29use constant PTDEBUG => $ENV{PTDEBUG} || 0;
30
31# server is the "host:port" of the sever being watched. It's auto-guessed if
32# not specified.
33sub new {
34 my ( $class, %args ) = @_;
35 my $self = $class->SUPER::new(
36 %args,
37 port => 80,
38 );
39 return $self;
40}
41
42# Handles a packet from the server given the state of the session. Returns an
43# event if one was ready to be created, otherwise returns nothing.
44sub _packet_from_server {
45 my ( $self, $packet, $session, $misc ) = @_;
46 die "I need a packet" unless $packet;
47 die "I need a session" unless $session;
48
49 PTDEBUG && _d('Packet is from server; client state:', $session->{state});
50
51 # If there's no session state, then we're catching a server response
52 # mid-stream.
53 if ( !$session->{state} ) {
54 PTDEBUG && _d('Ignoring mid-stream server response');
55 return;
56 }
57
58 if ( $session->{out_of_order} ) {
59 # We're waiting for the header so we can get the content length.
60 # Once we know this, we can determine how many out of order packets
61 # we need to complete the request, then order them and re-process.
62 my ($line1, $content);
63 if ( !$session->{have_header} ) {
64 ($line1, $content) = $self->_parse_header(
65 $session, $packet->{data}, $packet->{data_len});
66 }
67 if ( $line1 ) {
68 $session->{have_header} = 1;
69 $packet->{content_len} = length $content;
70 PTDEBUG && _d('Got out of order header with',
71 $packet->{content_len}, 'bytes of content');
72 }
73 my $have_len = $packet->{content_len} || $packet->{data_len};
74 map { $have_len += $_->{data_len} }
75 @{$session->{packets}};
76 $session->{have_all_packets}
77 = 1 if $session->{attribs}->{bytes}
78 && $have_len >= $session->{attribs}->{bytes};
79 PTDEBUG && _d('Have', $have_len, 'of', $session->{attribs}->{bytes});
80 return;
81 }
82
83 # Assume that the server is returning only one value.
84 # TODO: make it handle multiple.
85 if ( $session->{state} eq 'awaiting reply' ) {
86
87 # Save this early because we may return early if the packets
88 # are being received out of order. Also, save it only once
89 # in case we re-process packets if they're out of order.
90 $session->{start_reply} = $packet->{ts} unless $session->{start_reply};
91
92 # Get first line of header and first chunk of contents/data.
93 my ($line1, $content) = $self->_parse_header($session, $packet->{data},
94 $packet->{data_len});
95
96 # The reponse, when in order, is text header followed by data.
97 # If there's no line1, then we didn't get the text header first
98 # which means we're getting the response in out of order packets.
99 if ( !$line1 ) {
100 $session->{out_of_order} = 1; # alert parent
101 $session->{have_all_packets} = 0;
102 return;
103 }
104
105 # First line should be: version code phrase
106 # E.g.: HTTP/1.1 200 OK
107 my ($version, $code, $phrase) = $line1 =~ m/(\S+)/g;
108 $session->{attribs}->{Status_code} = $code;
109 PTDEBUG && _d('Status code for last', $session->{attribs}->{arg},
110 'request:', $session->{attribs}->{Status_code});
111
112 my $content_len = $content ? length $content : 0;
113 PTDEBUG && _d('Got', $content_len, 'bytes of content');
114 if ( $session->{attribs}->{bytes}
115 && $content_len < $session->{attribs}->{bytes} ) {
116 $session->{data_len} = $session->{attribs}->{bytes};
117 $session->{buff} = $content;
118 $session->{buff_left} = $session->{attribs}->{bytes} - $content_len;
119 PTDEBUG && _d('Contents not complete,', $session->{buff_left},
120 'bytes left');
121 $session->{state} = 'recving content';
122 return;
123 }
124 }
125 elsif ( $session->{state} eq 'recving content' ) {
126 if ( $session->{buff} ) {
127 PTDEBUG && _d('Receiving content,', $session->{buff_left},
128 'bytes left');
129 return;
130 }
131 PTDEBUG && _d('Contents received');
132 }
133 else {
134 # TODO:
135 warn "Server response in unknown state";
136 return;
137 }
138
139 PTDEBUG && _d('Creating event, deleting session');
140 $session->{end_reply} = $session->{ts_max} || $packet->{ts};
141 my $event = $self->make_event($session, $packet);
142 delete $self->{sessions}->{$session->{client}}; # http is stateless!
143 return $event;
144}
145
146# Handles a packet from the client given the state of the session.
147sub _packet_from_client {
148 my ( $self, $packet, $session, $misc ) = @_;
149 die "I need a packet" unless $packet;
150 die "I need a session" unless $session;
151
152 PTDEBUG && _d('Packet is from client; state:', $session->{state});
153
154 my $event;
155 if ( ($session->{state} || '') =~ m/awaiting / ) {
156 PTDEBUG && _d('More client headers:', $packet->{data});
157 return;
158 }
159
160 if ( !$session->{state} ) {
161 $session->{state} = 'awaiting reply';
162 my ($line1, undef) = $self->_parse_header($session, $packet->{data}, $packet->{data_len});
163 # First line should be: request page version
164 # E.g.: GET /foo.html HTTP/1.1
165 my ($request, $page, $version) = $line1 =~ m/(\S+)/g;
166 if ( !$request || !$page ) {
167 PTDEBUG && _d("Didn't get a request or page:", $request, $page);
168 return;
169 }
170 $request = lc $request;
171 my $vh = $session->{attribs}->{Virtual_host} || '';
172 my $arg = "$request $vh$page";
173 PTDEBUG && _d('arg:', $arg);
174
175 if ( $request eq 'get' || $request eq 'post' ) {
176 @{$session->{attribs}}{qw(arg)} = ($arg);
177 }
178 else {
179 PTDEBUG && _d("Don't know how to handle a", $request, "request");
180 return;
181 }
182
183 $session->{start_request} = $packet->{ts};
184 $session->{attribs}->{host} = $packet->{src_host};
185 $session->{attribs}->{pos_in_log} = $packet->{pos_in_log};
186 $session->{attribs}->{ts} = $packet->{ts};
187 }
188 else {
189 # TODO:
190 die "Probably multiple GETs from client before a server response?";
191 }
192
193 return $event;
194}
195
196sub _parse_header {
197 my ( $self, $session, $data, $len, $no_recurse ) = @_;
198 die "I need data" unless $data;
199 my ($header, $content) = split(/\r\n\r\n/, $data);
200 my ($line1, $header_vals) = $header =~ m/\A(\S+ \S+ .+?)\r\n(.+)?/s;
201 PTDEBUG && _d('HTTP header:', $line1);
202 return unless $line1;
203
204 if ( !$header_vals ) {
205 PTDEBUG && _d('No header vals');
206 return $line1, undef;
207 }
208 my @headers;
209 foreach my $val ( split(/\r\n/, $header_vals) ) {
210 last unless $val;
211 # Capture and save any useful header values.
212 PTDEBUG && _d('HTTP header:', $val);
213 if ( $val =~ m/^Content-Length/i ) {
214 ($session->{attribs}->{bytes}) = $val =~ /: (\d+)/;
215 PTDEBUG && _d('Saved Content-Length:', $session->{attribs}->{bytes});
216 }
217 if ( $val =~ m/Content-Encoding/i ) {
218 ($session->{compressed}) = $val =~ /: (\w+)/;
219 PTDEBUG && _d('Saved Content-Encoding:', $session->{compressed});
220 }
221 if ( $val =~ m/^Host/i ) {
222 # The "host" attribute is already taken, so we call this "domain".
223 ($session->{attribs}->{Virtual_host}) = $val =~ /: (\S+)/;
224 PTDEBUG && _d('Saved Host:', ($session->{attribs}->{Virtual_host}));
225 }
226 }
227 return $line1, $content;
228}
229
230sub _d {
231 my ($package, undef, $line) = caller 0;
232 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
233 map { defined $_ ? $_ : 'undef' }
234 @_;
235 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
236}
237
2381;
239}
240# ###########################################################################
241# End HTTPProtocolParser package
242# ###########################################################################
2430
=== removed file 'lib/MemcachedEvent.pm'
--- lib/MemcachedEvent.pm 2013-01-03 00:19:16 +0000
+++ lib/MemcachedEvent.pm 1970-01-01 00:00:00 +0000
@@ -1,216 +0,0 @@
1# This program is copyright 2009-2011 Percona Ireland Ltd.
2# Feedback and improvements are welcome.
3#
4# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
5# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
7#
8# This program is free software; you can redistribute it and/or modify it under
9# the terms of the GNU General Public License as published by the Free Software
10# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
11# systems, you can issue `man perlgpl' or `man perlartistic' to read these
12# licenses.
13#
14# You should have received a copy of the GNU General Public License along with
15# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
16# Place, Suite 330, Boston, MA 02111-1307 USA.
17# ###########################################################################
18# MemcachedEvent package
19# ###########################################################################
20{
21# Package: MemcachedEvent
22# MemcachedEvent creates events from <MemcachedProtocolParser> data.
23# Since memcached is not strictly MySQL stuff, we have to
24# fabricate MySQL-like query events from memcached.
25#
26# See http://code.sixapart.com/svn/memcached/trunk/server/doc/protocol.txt
27# for information about the memcached protocol.
28package MemcachedEvent;
29
30use strict;
31use warnings FATAL => 'all';
32use English qw(-no_match_vars);
33use constant PTDEBUG => $ENV{PTDEBUG} || 0;
34
35use Data::Dumper;
36$Data::Dumper::Indent = 1;
37$Data::Dumper::Sortkeys = 1;
38$Data::Dumper::Quotekeys = 0;
39
40# cmds that we know how to handle.
41my %cmds = map { $_ => 1 } qw(
42 set
43 add
44 replace
45 append
46 prepend
47 cas
48 get
49 gets
50 delete
51 incr
52 decr
53);
54
55my %cmd_handler_for = (
56 set => \&handle_storage_cmd,
57 add => \&handle_storage_cmd,
58 replace => \&handle_storage_cmd,
59 append => \&handle_storage_cmd,
60 prepend => \&handle_storage_cmd,
61 cas => \&handle_storage_cmd,
62 get => \&handle_retr_cmd,
63 gets => \&handle_retr_cmd,
64);
65
66sub new {
67 my ( $class, %args ) = @_;
68 my $self = {};
69 return bless $self, $class;
70}
71
72# Given an event from MemcachedProtocolParser, returns an event
73# more suitable for mk-query-digest.
74sub parse_event {
75 my ( $self, %args ) = @_;
76 my $event = $args{event};
77 return unless $event;
78
79 if ( !$event->{cmd} || !$event->{key} ) {
80 PTDEBUG && _d('Event has no cmd or key:', Dumper($event));
81 return;
82 }
83
84 if ( !$cmds{$event->{cmd}} ) {
85 PTDEBUG && _d("Don't know how to handle cmd:", $event->{cmd});
86 return;
87 }
88
89 # For a normal event, arg is the query. For memcached, the "query" is
90 # essentially the cmd and key, so this becomes arg. E.g.: "set mk_key".
91 $event->{arg} = "$event->{cmd} $event->{key}";
92 $event->{fingerprint} = $self->fingerprint($event->{arg});
93 $event->{key_print} = $self->fingerprint($event->{key});
94
95 # Set every cmd so that aggregated totals will be correct. If we only
96 # set cmd that we get, then all cmds will show as 100% in the report.
97 # This will create a lot of 0% cmds, but --[no]zero-bool will remove them.
98 # Think of events in a Percona-patched log: the attribs like Full_scan are
99 # present for every event.
100 map { $event->{"Memc_$_"} = 'No' } keys %cmds;
101 $event->{"Memc_$event->{cmd}"} = 'Yes'; # Got this cmd.
102 $event->{Memc_error} = 'No'; # A handler may change this.
103 $event->{Memc_miss} = 'No';
104 if ( $event->{res} ) {
105 $event->{Memc_miss} = 'Yes' if $event->{res} eq 'NOT_FOUND';
106 }
107 else {
108 # This normally happens with incr and decr cmds.
109 PTDEBUG && _d('Event has no res:', Dumper($event));
110 }
111
112 # Handle special results, errors, etc. The handler should return the
113 # event on success, or nothing on failure.
114 if ( $cmd_handler_for{$event->{cmd}} ) {
115 return $cmd_handler_for{$event->{cmd}}->($event);
116 }
117
118 return $event;
119}
120
121# Replace things that look like placeholders with a ?
122sub fingerprint {
123 my ( $self, $val ) = @_;
124 $val =~ s/[0-9A-Fa-f]{16,}|\d+/?/g;
125 return $val;
126}
127
128# Possible results for storage cmds:
129# - "STORED\r\n", to indicate success.
130#
131# - "NOT_STORED\r\n" to indicate the data was not stored, but not
132# because of an error. This normally means that either that the
133# condition for an "add" or a "replace" command wasn't met, or that the
134# item is in a delete queue (see the "delete" command below).
135#
136# - "EXISTS\r\n" to indicate that the item you are trying to store with
137# a "cas" command has been modified since you last fetched it.
138#
139# - "NOT_FOUND\r\n" to indicate that the item you are trying to store
140# with a "cas" command did not exist or has been deleted.
141sub handle_storage_cmd {
142 my ( $event ) = @_;
143
144 # There should be a result for any storage cmd.
145 if ( !$event->{res} ) {
146 PTDEBUG && _d('No result for event:', Dumper($event));
147 return;
148 }
149
150 $event->{'Memc_Not_Stored'} = $event->{res} eq 'NOT_STORED' ? 'Yes' : 'No';
151 $event->{'Memc_Exists'} = $event->{res} eq 'EXISTS' ? 'Yes' : 'No';
152
153 return $event;
154}
155
156# Technically, the only results for a retrieval cmd are the values requested.
157# "If some of the keys appearing in a retrieval request are not sent back
158# by the server in the item list this means that the server does not
159# hold items with such keys (because they were never stored, or stored
160# but deleted to make space for more items, or expired, or explicitly
161# deleted by a client)."
162# Contrary to this, MemcacedProtocolParser will set res='VALUE' on
163# success, res='NOT_FOUND' on failure, or res='INTERRUPTED' if the get
164# didn't finish.
165sub handle_retr_cmd {
166 my ( $event ) = @_;
167
168 # There should be a result for any retr cmd.
169 if ( !$event->{res} ) {
170 PTDEBUG && _d('No result for event:', Dumper($event));
171 return;
172 }
173
174 $event->{'Memc_error'} = $event->{res} eq 'INTERRUPTED' ? 'Yes' : 'No';
175
176 return $event;
177}
178
179# handle_delete() and handle_incr_decr_cmd() are stub subs in case we
180# need them later.
181
182# Possible results for a delete cmd:
183# - "DELETED\r\n" to indicate success
184#
185# - "NOT_FOUND\r\n" to indicate that the item with this key was not
186# found.
187sub handle_delete {
188 my ( $event ) = @_;
189 return $event;
190}
191
192# Possible results for an incr or decr cmd:
193# - "NOT_FOUND\r\n" to indicate the item with this value was not found
194#
195# - <value>\r\n , where <value> is the new value of the item's data,
196# after the increment/decrement operation was carried out.
197# On success, MemcachedProtocolParser sets res='' and val=the new val.
198# On failure, res=the result and val=''.
199sub handle_incr_decr_cmd {
200 my ( $event ) = @_;
201 return $event;
202}
203
204sub _d {
205 my ($package, undef, $line) = caller 0;
206 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
207 map { defined $_ ? $_ : 'undef' }
208 @_;
209 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
210}
211
2121;
213}
214# ###########################################################################
215# End MemcachedEvent package
216# ###########################################################################
2170
=== removed file 'lib/MemcachedProtocolParser.pm'
--- lib/MemcachedProtocolParser.pm 2013-01-03 00:19:16 +0000
+++ lib/MemcachedProtocolParser.pm 1970-01-01 00:00:00 +0000
@@ -1,424 +0,0 @@
1# This program is copyright 2007-2011 Percona Ireland Ltd.
2# Feedback and improvements are welcome.
3#
4# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
5# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
7#
8# This program is free software; you can redistribute it and/or modify it under
9# the terms of the GNU General Public License as published by the Free Software
10# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
11# systems, you can issue `man perlgpl' or `man perlartistic' to read these
12# licenses.
13#
14# You should have received a copy of the GNU General Public License along with
15# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
16# Place, Suite 330, Boston, MA 02111-1307 USA.
17# ###########################################################################
18# MemcachedProtocolParser package
19# ###########################################################################
20{
21# Package: MemcachedProtocolParser
22# MemcachedProtocolParser parses memcached events from tcpdump files.
23package MemcachedProtocolParser;
24
25use strict;
26use warnings FATAL => 'all';
27use English qw(-no_match_vars);
28
29use Data::Dumper;
30$Data::Dumper::Indent = 1;
31$Data::Dumper::Sortkeys = 1;
32$Data::Dumper::Quotekeys = 0;
33
34use constant PTDEBUG => $ENV{PTDEBUG} || 0;
35
36sub new {
37 my ( $class, %args ) = @_;
38
39 my $self = {
40 server => $args{server},
41 port => $args{port} || '11211',
42 sessions => {},
43 o => $args{o},
44 };
45 return bless $self, $class;
46}
47
48# The packet arg should be a hashref from TcpdumpParser::parse_event().
49# misc is a placeholder for future features.
50sub parse_event {
51 my ( $self, %args ) = @_;
52 my @required_args = qw(event);
53 foreach my $arg ( @required_args ) {
54 die "I need a $arg argument" unless $args{$arg};
55 }
56 my $packet = @args{@required_args};
57
58 # Return early if there's no TCP data. These are usually ACK packets, but
59 # they could also be FINs in which case, we should close and delete the
60 # client's session.
61 # TODO: It seems we don't handle FIN here? So I moved this code block here.
62 if ( $packet->{data_len} == 0 ) {
63 PTDEBUG && _d('No TCP data');
64 $args{stats}->{no_tcp_data}++ if $args{stats};
65 return;
66 }
67
68 my $src_host = "$packet->{src_host}:$packet->{src_port}";
69 my $dst_host = "$packet->{dst_host}:$packet->{dst_port}";
70
71 if ( my $server = $self->{server} ) { # Watch only the given server.
72 $server .= ":$self->{port}";
73 if ( $src_host ne $server && $dst_host ne $server ) {
74 PTDEBUG && _d('Packet is not to or from', $server);
75 $args{stats}->{not_watched_server}++ if $args{stats};
76 return;
77 }
78 }
79
80 # Auto-detect the server by looking for port 11211
81 my $packet_from;
82 my $client;
83 if ( $src_host =~ m/:$self->{port}$/ ) {
84 $packet_from = 'server';
85 $client = $dst_host;
86 }
87 elsif ( $dst_host =~ m/:$self->{port}$/ ) {
88 $packet_from = 'client';
89 $client = $src_host;
90 }
91 else {
92 warn 'Packet is not to or from memcached server: ', Dumper($packet);
93 return;
94 }
95 PTDEBUG && _d('Client:', $client);
96
97 # Get the client's session info or create a new session if the
98 # client hasn't been seen before.
99 if ( !exists $self->{sessions}->{$client} ) {
100 PTDEBUG && _d('New session');
101 $self->{sessions}->{$client} = {
102 client => $client,
103 state => undef,
104 raw_packets => [],
105 # ts -- wait for ts later.
106 };
107 };
108 my $session = $self->{sessions}->{$client};
109
110 # Save raw packets to dump later in case something fails.
111 push @{$session->{raw_packets}}, $packet->{raw_packet};
112
113 # Finally, parse the packet and maybe create an event.
114 $packet->{data} = pack('H*', $packet->{data});
115 my $event;
116 if ( $packet_from eq 'server' ) {
117 $event = $self->_packet_from_server($packet, $session, %args);
118 }
119 elsif ( $packet_from eq 'client' ) {
120 $event = $self->_packet_from_client($packet, $session, %args);
121 }
122 else {
123 # Should not get here.
124 $args{stats}->{unknown_packet_origin}++ if $args{stats};
125 die 'Packet origin unknown';
126 }
127
128 PTDEBUG && _d('Done with packet; event:', Dumper($event));
129 $args{stats}->{events_parsed}++ if $args{stats};
130 return $event;
131}
132
133# Handles a packet from the server given the state of the session. Returns an
134# event if one was ready to be created, otherwise returns nothing.
135sub _packet_from_server {
136 my ( $self, $packet, $session, %args ) = @_;
137 die "I need a packet" unless $packet;
138 die "I need a session" unless $session;
139
140 PTDEBUG && _d('Packet is from server; client state:', $session->{state});
141
142 my $data = $packet->{data};
143
144 # If there's no session state, then we're catching a server response
145 # mid-stream.
146 if ( !$session->{state} ) {
147 PTDEBUG && _d('Ignoring mid-stream server response');
148 $args{stats}->{ignored_midstream_server_response}++ if $args{stats};
149 return;
150 }
151
152 # Assume that the server is returning only one value. TODO: make it
153 # handle multi-gets.
154 if ( $session->{state} eq 'awaiting reply' ) {
155 PTDEBUG && _d('State is awaiting reply');
156 # \r\n == 0d0a
157 my ($line1, $rest) = $packet->{data} =~ m/\A(.*?)\r\n(.*)?/s;
158 if ( !$line1 ) {
159 $args{stats}->{unknown_server_data}++ if $args{stats};
160 die "Unknown memcached data from server";
161 }
162
163 # Split up the first line into its parts.
164 my @vals = $line1 =~ m/(\S+)/g;
165 $session->{res} = shift @vals;
166 PTDEBUG && _d('Result of last', $session->{cmd}, 'cmd:', $session->{res});
167
168 if ( $session->{cmd} eq 'incr' || $session->{cmd} eq 'decr' ) {
169 PTDEBUG && _d('It is an incr or decr');
170 if ( $session->{res} !~ m/\D/ ) { # It's an integer, not an error
171 PTDEBUG && _d('Got a value for the incr/decr');
172 $session->{val} = $session->{res};
173 $session->{res} = '';
174 }
175 }
176 elsif ( $session->{res} eq 'VALUE' ) {
177 PTDEBUG && _d('It is the result of a "get"');
178 my ($key, $flags, $bytes) = @vals;
179 defined $session->{flags} or $session->{flags} = $flags;
180 defined $session->{bytes} or $session->{bytes} = $bytes;
181
182 # Get the value from the $rest.
183 # TODO: there might be multiple responses
184 if ( $rest && $bytes ) {
185 PTDEBUG && _d('There is a value');
186 if ( length($rest) > $bytes ) {
187 PTDEBUG && _d('Got complete response');
188 $session->{val} = substr($rest, 0, $bytes);
189 }
190 else {
191 PTDEBUG && _d('Got partial response, saving for later');
192 push @{$session->{partial}}, [ $packet->{seq}, $rest ];
193 $session->{gathered} += length($rest);
194 $session->{state} = 'partial recv';
195 return; # Prevent firing an event.
196 }
197 }
198 }
199 elsif ( $session->{res} eq 'END' ) {
200 # Technically NOT_FOUND is an error, and this isn't an error it's just
201 # a NULL, but what it really means is the value isn't found.
202 PTDEBUG && _d('Got an END without any data, firing NOT_FOUND');
203 $session->{res} = 'NOT_FOUND';
204 }
205 elsif ( $session->{res} !~ m/STORED|DELETED|NOT_FOUND/ ) {
206 # Not really sure what else would get us here... want to make a note
207 # and not have an uncaught condition.
208 PTDEBUG && _d('Unknown result');
209 }
210 else {
211 $args{stats}->{unknown_server_response}++ if $args{stats};
212 }
213 }
214 else { # Should be 'partial recv'
215 PTDEBUG && _d('Session state: ', $session->{state});
216 push @{$session->{partial}}, [ $packet->{seq}, $data ];
217 $session->{gathered} += length($data);
218 PTDEBUG && _d('Gathered', $session->{gathered}, 'bytes in',
219 scalar(@{$session->{partial}}), 'packets from server');
220 if ( $session->{gathered} >= $session->{bytes} + 2 ) { # Done.
221 PTDEBUG && _d('End of partial response, preparing event');
222 my $val = join('',
223 map { $_->[1] }
224 # Sort in proper sequence because TCP might reorder them.
225 sort { $a->[0] <=> $b->[0] }
226 @{$session->{partial}});
227 $session->{val} = substr($val, 0, $session->{bytes});
228 }
229 else {
230 PTDEBUG && _d('Partial response continues, no action');
231 return; # Prevent firing event.
232 }
233 }
234
235 PTDEBUG && _d('Creating event, deleting session');
236 my $event = make_event($session, $packet);
237 delete $self->{sessions}->{$session->{client}}; # memcached is stateless!
238 $session->{raw_packets} = []; # Avoid keeping forever
239 return $event;
240}
241
242# Handles a packet from the client given the state of the session.
243sub _packet_from_client {
244 my ( $self, $packet, $session, %args ) = @_;
245 die "I need a packet" unless $packet;
246 die "I need a session" unless $session;
247
248 PTDEBUG && _d('Packet is from client; state:', $session->{state});
249
250 my $event;
251 if ( ($session->{state} || '') =~m/awaiting reply|partial recv/ ) {
252 # Whoa, we expected something from the server, not the client. Fire an
253 # INTERRUPTED with what we've got, and create a new session.
254 PTDEBUG && _d("Expected data from the client, looks like interrupted");
255 $session->{res} = 'INTERRUPTED';
256 $event = make_event($session, $packet);
257 my $client = $session->{client};
258 delete @{$session}{keys %$session};
259 $session->{client} = $client;
260 }
261
262 my ($line1, $val);
263 my ($cmd, $key, $flags, $exptime, $bytes);
264
265 if ( !$session->{state} ) {
266 PTDEBUG && _d('Session state: ', $session->{state});
267 # Split up the first line into its parts.
268 ($line1, $val) = $packet->{data} =~ m/\A(.*?)\r\n(.+)?/s;
269 if ( !$line1 ) {
270 PTDEBUG && _d('Unknown memcached data from client, skipping packet');
271 $args{stats}->{unknown_client_data}++ if $args{stats};
272 return;
273 }
274
275 # TODO: handle <cas unique> and [noreply]
276 my @vals = $line1 =~ m/(\S+)/g;
277 $cmd = lc shift @vals;
278 PTDEBUG && _d('$cmd is a ', $cmd);
279 if ( $cmd eq 'set' || $cmd eq 'add' || $cmd eq 'replace' ) {
280 ($key, $flags, $exptime, $bytes) = @vals;
281 $session->{bytes} = $bytes;
282 }
283 elsif ( $cmd eq 'get' ) {
284 ($key) = @vals;
285 if ( $val ) {
286 PTDEBUG && _d('Multiple cmds:', $val);
287 $val = undef;
288 }
289 }
290 elsif ( $cmd eq 'delete' ) {
291 ($key) = @vals; # TODO: handle the <queue_time>
292 if ( $val ) {
293 PTDEBUG && _d('Multiple cmds:', $val);
294 $val = undef;
295 }
296 }
297 elsif ( $cmd eq 'incr' || $cmd eq 'decr' ) {
298 ($key) = @vals;
299 }
300 else {
301 PTDEBUG && _d("Don't know how to handle", $cmd, "command");
302 $args{stats}->{unknown_client_command}++ if $args{stats};
303 return;
304 }
305
306 @{$session}{qw(cmd key flags exptime)}
307 = ($cmd, $key, $flags, $exptime);
308 $session->{host} = $packet->{src_host};
309 $session->{pos_in_log} = $packet->{pos_in_log};
310 $session->{ts} = $packet->{ts};
311 }
312 else {
313 PTDEBUG && _d('Session state: ', $session->{state});
314 $val = $packet->{data};
315 }
316
317 # Handle the rest of the packet. It might not be the whole value that was
318 # sent, for example for a big set(). We need to look at the number of bytes
319 # and see if we got it all.
320 $session->{state} = 'awaiting reply'; # Assume we got the whole packet
321 if ( $val ) {
322 if ( $session->{bytes} + 2 == length($val) ) { # +2 for the \r\n
323 PTDEBUG && _d('Complete send');
324 $val =~ s/\r\n\Z//; # We got the whole thing.
325 $session->{val} = $val;
326 }
327 else { # We apparently did NOT get the whole thing.
328 PTDEBUG && _d('Partial send, saving for later');
329 push @{$session->{partial}},
330 [ $packet->{seq}, $val ];
331 $session->{gathered} += length($val);
332 PTDEBUG && _d('Gathered', $session->{gathered}, 'bytes in',
333 scalar(@{$session->{partial}}), 'packets from client');
334 if ( $session->{gathered} >= $session->{bytes} + 2 ) { # Done.
335 PTDEBUG && _d('Message looks complete now, saving value');
336 $val = join('',
337 map { $_->[1] }
338 # Sort in proper sequence because TCP might reorder them.
339 sort { $a->[0] <=> $b->[0] }
340 @{$session->{partial}});
341 $val =~ s/\r\n\Z//;
342 $session->{val} = $val;
343 }
344 else {
345 PTDEBUG && _d('Message not complete');
346 $val = '[INCOMPLETE]';
347 $session->{state} = 'partial send';
348 }
349 }
350 }
351
352 return $event;
353}
354
355# The event is not yet suitable for mk-query-digest. It lacks, for example,
356# an arg and fingerprint attribute. The event should be passed to
357# MemcachedEvent::make_event() to transform it.
358sub make_event {
359 my ( $session, $packet ) = @_;
360 my $event = {
361 cmd => $session->{cmd},
362 key => $session->{key},
363 val => $session->{val} || '',
364 res => $session->{res},
365 ts => $session->{ts},
366 host => $session->{host},
367 flags => $session->{flags} || 0,
368 exptime => $session->{exptime} || 0,
369 bytes => $session->{bytes} || 0,
370 Query_time => timestamp_diff($session->{ts}, $packet->{ts}),
371 pos_in_log => $session->{pos_in_log},
372 };
373 return $event;
374}
375
376sub _get_errors_fh {
377 my ( $self ) = @_;
378 my $errors_fh = $self->{errors_fh};
379 return $errors_fh if $errors_fh;
380
381 # Errors file isn't open yet; try to open it.
382 my $o = $self->{o};
383 if ( $o && $o->has('tcpdump-errors') && $o->got('tcpdump-errors') ) {
384 my $errors_file = $o->get('tcpdump-errors');
385 PTDEBUG && _d('tcpdump-errors file:', $errors_file);
386 open $errors_fh, '>>', $errors_file
387 or die "Cannot open tcpdump-errors file $errors_file: $OS_ERROR";
388 }
389
390 $self->{errors_fh} = $errors_fh;
391 return $errors_fh;
392}
393
394sub _d {
395 my ($package, undef, $line) = caller 0;
396 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
397 map { defined $_ ? $_ : 'undef' }
398 @_;
399 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
400}
401
402# Returns the difference between two tcpdump timestamps. TODO: this is in
403# MySQLProtocolParser too, best to factor it out somewhere common.
404sub timestamp_diff {
405 my ( $start, $end ) = @_;
406 my $sd = substr($start, 0, 11, '');
407 my $ed = substr($end, 0, 11, '');
408 my ( $sh, $sm, $ss ) = split(/:/, $start);
409 my ( $eh, $em, $es ) = split(/:/, $end);
410 my $esecs = ($eh * 3600 + $em * 60 + $es);
411 my $ssecs = ($sh * 3600 + $sm * 60 + $ss);
412 if ( $sd eq $ed ) {
413 return sprintf '%.6f', $esecs - $ssecs;
414 }
415 else { # Assume only one day boundary has been crossed, no DST, etc
416 return sprintf '%.6f', ( 86_400 - $ssecs ) + $esecs;
417 }
418}
419
4201;
421}
422# ###########################################################################
423# End MemcachedProtocolParser package
424# ###########################################################################
4250
=== removed file 'lib/PgLogParser.pm'
--- lib/PgLogParser.pm 2013-01-03 00:19:16 +0000
+++ lib/PgLogParser.pm 1970-01-01 00:00:00 +0000
@@ -1,669 +0,0 @@
1# This program is copyright 2010-2011 Baron Schwartz, 2011 Percona Ireland Ltd.
2# Feedback and improvements are welcome.
3#
4# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
5# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
7#
8# This program is free software; you can redistribute it and/or modify it under
9# the terms of the GNU General Public License as published by the Free Software
10# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
11# systems, you can issue `man perlgpl' or `man perlartistic' to read these
12# licenses.
13#
14# You should have received a copy of the GNU General Public License along with
15# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
16# Place, Suite 330, Boston, MA 02111-1307 USA.
17# ###########################################################################
18# PgLogParser package
19# ###########################################################################
20{
21# Package: PgLogParser
22# PgLogParser parses Postgres logs.
23package PgLogParser;
24
25use strict;
26use warnings FATAL => 'all';
27use English qw(-no_match_vars);
28use constant PTDEBUG => $ENV{PTDEBUG} || 0;
29
30use Data::Dumper;
31$Data::Dumper::Indent = 1;
32$Data::Dumper::Sortkeys = 1;
33$Data::Dumper::Quotekeys = 0;
34
35# This regex is partially inspired by one from pgfouine. But there is no
36# documentation on the last capture in that regex, so I omit that. (TODO: that
37# actually seems to be for CSV logging.)
38# (?:[0-9XPFDBLA]{2}[0-9A-Z]{3}:[\s]+)?
39# Here I constrain to match at least two spaces after the severity level,
40# because the source code tells me to. I believe this is controlled in elog.c:
41# appendStringInfo(&buf, "%s: ", error_severity(edata->elevel));
42my $log_line_regex = qr{
43 (LOG|DEBUG|CONTEXT|WARNING|ERROR|FATAL|PANIC|HINT
44 |DETAIL|NOTICE|STATEMENT|INFO|LOCATION)
45 :\s\s+
46 }x;
47
48# The following are taken right from the comments in postgresql.conf for
49# log_line_prefix.
50my %attrib_name_for = (
51 u => 'user',
52 d => 'db',
53 r => 'host', # With port
54 h => 'host',
55 p => 'Process_id',
56 t => 'ts',
57 m => 'ts', # With milliseconds
58 i => 'Query_type',
59 c => 'Session_id',
60 l => 'Line_no',
61 s => 'Session_id',
62 v => 'Vrt_trx_id',
63 x => 'Trx_id',
64);
65
66# This class's data structure is a hashref with some statefulness: pending
67# lines. This is necessary because we sometimes don't know whether the event is
68# complete until we read the next line or even several lines, so we store these.
69#
70# Another bit of data that's stored in $self is some code to automatically
71# translate syslog into plain log format.
72sub new {
73 my ( $class ) = @_;
74 my $self = {
75 pending => [],
76 is_syslog => undef,
77 next_event => undef,
78 'tell' => undef,
79 };
80 return bless $self, $class;
81}
82
83# This method accepts an iterator that contains an open log filehandle. It
84# reads events from the filehandle by calling the iterator, and returns the
85# events.
86#
87# Each event is a hashref of attribute => value pairs like:
88# my $event = {
89# ts => '', # Timestamp
90# arg => '', # Argument to the command
91# other attributes...
92# };
93#
94# The log format is ideally prefixed with the following:
95#
96# * timestamp with microseconds
97# * session ID, user, database
98#
99# The format I'd like to see is something like this:
100#
101# 2010-02-08 15:31:48.685 EST c=4b7074b4.985,u=user,D=database LOG:
102#
103# However, pgfouine supports user=user, db=database format. And I think
104# it should be reasonable to grab pretty much any name=value properties out, and
105# handle them based on the lower-cased first character of $name, to match the
106# special values that are possible to give for log_line_prefix. For example, %u
107# = user, so anything starting with a 'u' should be interpreted as a user.
108#
109# In general the log format is rather flexible, and we don't know by looking at
110# any given line whether it's the last line in the event. So we often have to
111# read a line and then decide what to do with the previous line we saw. Thus we
112# use 'pending' when necessary but we try to do it as little as possible,
113# because it's double work to defer and re-parse lines; and we try to defer as
114# soon as possible so we don't have to do as much work.
115#
116# There are 3 categories of lines in a log file, referred to in the code as case
117# 1/2/3:
118#
119# - Those that start a possibly multi-line event
120# - Those that can continue one
121# - Those that are neither the start nor the continuation, and thus must be the
122# end.
123#
124# In cases 1 and 3, we have to check whether information from previous lines has
125# been accumulated. If it has, we defer the current line and create the event.
126# Otherwise we keep going, looking for more lines for the event that begins with
127# the current line. Processing the lines is easiest if we arrange the cases in
128# this order: 2, 1, 3.
129#
130# The term "line" is to be interpreted loosely here. Logs that are in syslog
131# format might have multi-line "lines" that are handled by the generated
132# $next_event closure and given back to the main while-loop with newlines in
133# them. Therefore, regexes that match "the rest of the line" generally need the
134# /s flag.
135sub parse_event {
136 my ( $self, %args ) = @_;
137 my @required_args = qw(next_event tell);
138 foreach my $arg ( @required_args ) {
139 die "I need a $arg argument" unless $args{$arg};
140 }
141
142 # The subroutine references that wrap the filehandle operations.
143 my ( $next_event, $tell, $is_syslog ) = $self->generate_wrappers(%args);
144
145 # These are the properties for the log event, which will later be used to
146 # create an event hash ref.
147 my @properties = ();
148
149 # Holds the current line being processed, and its position in the log as a
150 # byte offset from the beginning. In some cases we'll have to reset this
151 # position later. We'll also have to take a wait-and-see attitude towards
152 # the $pos_in_log, so we use $new_pos to record where we're working in the
153 # log, and $pos_in_log to record where the beginning of the current event
154 # started.
155 my ($pos_in_log, $line, $was_pending) = $self->get_line();
156 my $new_pos;
157
158 # Sometimes we need to accumulate some lines and then join them together.
159 # This is used for that.
160 my @arg_lines;
161
162 # This is used to signal that an entire event has been found, and thus exit
163 # the while loop.
164 my $done;
165
166 # This is used to signal that an event's duration has already been found.
167 # See the sample file pg-syslog-001.txt and the test for it.
168 my $got_duration;
169
170 # Before we start, we read and discard lines until we get one with a header.
171 # The only thing we can really count on is that a header line should have
172 # the header in it. But, we only do this if we aren't in the middle of an
173 # ongoing event, whose first line was pending.
174 if ( !$was_pending && (!defined $line || $line !~ m/$log_line_regex/o) ) {
175 PTDEBUG && _d('Skipping lines until I find a header');
176 my $found_header;
177 LINE:
178 while (
179 eval {
180 ($new_pos, $line) = $self->get_line();
181 defined $line;
182 }
183 ) {
184 if ( $line =~ m/$log_line_regex/o ) {
185 $pos_in_log = $new_pos;
186 last LINE;
187 }
188 else {
189 PTDEBUG && _d('Line was not a header, will fetch another');
190 }
191 }
192 PTDEBUG && _d('Found a header line, now at pos_in_line', $pos_in_log);
193 }
194
195 # We need to keep the line that begins the event we're parsing.
196 my $first_line;
197
198 # This is for holding the type of the log line, which is important for
199 # choosing the right code to run.
200 my $line_type;
201
202 # Parse each line.
203 LINE:
204 while ( !$done && defined $line ) {
205
206 # Throw away the newline ending.
207 chomp $line unless $is_syslog;
208
209 # This while loop works with LOG lines. Other lines, such as ERROR and
210 # so forth, need to be handled outside this loop. The exception is when
211 # there's nothing in progress in @arg_lines, and the non-LOG line might
212 # just be something we can get relevant info from.
213 if ( (($line_type) = $line =~ m/$log_line_regex/o) && $line_type ne 'LOG' ) {
214
215 # There's something in progress, so we abort the loop and let it be
216 # handled specially.
217 if ( @arg_lines ) {
218 PTDEBUG && _d('Found a non-LOG line, exiting loop');
219 last LINE;
220 }
221
222 # There's nothing in @arg_lines, so we save what info we can and keep
223 # on going.
224 else {
225 $first_line ||= $line;
226
227 # Handle ERROR and STATEMENT lines...
228 if ( my ($e) = $line =~ m/ERROR:\s+(\S.*)\Z/s ) {
229 push @properties, 'Error_msg', $e;
230 PTDEBUG && _d('Found an error msg, saving and continuing');
231 ($new_pos, $line) = $self->get_line();
232 next LINE;
233 }
234
235 elsif ( my ($s) = $line =~ m/STATEMENT:\s+(\S.*)\Z/s ) {
236 push @properties, 'arg', $s, 'cmd', 'Query';
237 PTDEBUG && _d('Found a statement, finishing up event');
238 $done = 1;
239 last LINE;
240 }
241
242 else {
243 PTDEBUG && _d("I don't know what to do with this line");
244 }
245 }
246
247 }
248
249 # The log isn't just queries. It also has status and informational lines
250 # in it. We ignore these, but if we see one that's not recognized, we
251 # warn. These types of things are better off in mk-error-log.
252 if (
253 $line =~ m{
254 Address\sfamily\snot\ssupported\sby\sprotocol
255 |archived\stransaction\slog\sfile
256 |autovacuum:\sprocessing\sdatabase
257 |checkpoint\srecord\sis\sat
258 |checkpoints\sare\soccurring\stoo\sfrequently\s\(
259 |could\snot\sreceive\sdata\sfrom\sclient
260 |database\ssystem\sis\sready
261 |database\ssystem\sis\sshut\sdown
262 |database\ssystem\swas\sshut\sdown
263 |incomplete\sstartup\spacket
264 |invalid\slength\sof\sstartup\spacket
265 |next\sMultiXactId:
266 |next\stransaction\sID:
267 |received\ssmart\sshutdown\srequest
268 |recycled\stransaction\slog\sfile
269 |redo\srecord\sis\sat
270 |removing\sfile\s"
271 |removing\stransaction\slog\sfile\s"
272 |shutting\sdown
273 |transaction\sID\swrap\slimit\sis
274 }x
275 ) {
276 # We get the next line to process and skip the rest of the loop.
277 PTDEBUG && _d('Skipping this line because it matches skip-pattern');
278 ($new_pos, $line) = $self->get_line();
279 next LINE;
280 }
281
282 # Possibly reset $first_line, depending on whether it was determined to be
283 # junk and unset.
284 $first_line ||= $line;
285
286 # Case 2: non-header lines, optionally starting with a TAB, are a
287 # continuation of the previous line.
288 if ( $line !~ m/$log_line_regex/o && @arg_lines ) {
289
290 if ( !$is_syslog ) {
291 # We need to translate tabs to newlines. Weirdly, some logs (see
292 # samples/pg-log-005.txt) have newlines without a leading tab.
293 # Maybe it's an older log format.
294 $line =~ s/\A\t?/\n/;
295 }
296
297 # Save the remainder.
298 push @arg_lines, $line;
299 PTDEBUG && _d('This was a continuation line');
300 }
301
302 # Cases 1 and 3: These lines start with some optional meta-data, and then
303 # the $log_line_regex followed by the line's log message. The message can be
304 # of the form "label: text....". Examples:
305 # LOG: duration: 1.565 ms
306 # LOG: statement: SELECT ....
307 # LOG: duration: 1.565 ms statement: SELECT ....
308 # In the above examples, the $label is duration, statement, and duration.
309 elsif (
310 my ( $sev, $label, $rest )
311 = $line =~ m/$log_line_regex(.+?):\s+(.*)\Z/so
312 ) {
313 PTDEBUG && _d('Line is case 1 or case 3');
314
315 # This is either a case 1 or case 3. If there's previously gathered
316 # data in @arg_lines, it doesn't matter which -- we have to create an
317 # event (a Query event), and we're $done. This is case 0xdeadbeef.
318 if ( @arg_lines ) {
319 $done = 1;
320 PTDEBUG && _d('There are saved @arg_lines, we are done');
321
322 # We shouldn't modify @properties based on $line, because $line
323 # doesn't have anything to do with the stuff in @properties, which
324 # is all related to the previous line(s). However, there is one
325 # case in which the line could be part of the event: when it's a
326 # plain 'duration' line. This happens when the statement is logged
327 # on one line, and then the duration is logged afterwards. If this
328 # is true, then we alter @properties, and we do NOT defer the current
329 # line.
330 if ( $label eq 'duration' && $rest =~ m/[0-9.]+\s+\S+\Z/ ) {
331 if ( $got_duration ) {
332 # Just discard the line.
333 PTDEBUG && _d('Discarding line, duration already found');
334 }
335 else {
336 push @properties, 'Query_time', $self->duration_to_secs($rest);
337 PTDEBUG && _d("Line's duration is for previous event:", $rest);
338 }
339 }
340 else {
341 # We'll come back to this line later.
342 $self->pending($new_pos, $line);
343 PTDEBUG && _d('Deferred line');
344 }
345 }
346
347 # Here we test for case 1, lines that can start a multi-line event.
348 elsif ( $label =~ m/\A(?:duration|statement|query)\Z/ ) {
349 PTDEBUG && _d('Case 1: start a multi-line event');
350
351 # If it's a duration, then there might be a statement later on the
352 # same line and the duration applies to that.
353 if ( $label eq 'duration' ) {
354
355 if (
356 (my ($dur, $stmt)
357 = $rest =~ m/([0-9.]+ \S+)\s+(?:statement|query): *(.*)\Z/s)
358 ) {
359 # It does, so we'll pull out the Query_time etc now, rather
360 # than doing it later, when we might end up in the case above
361 # (case 0xdeadbeef).
362 push @properties, 'Query_time', $self->duration_to_secs($dur);
363 $got_duration = 1;
364 push @arg_lines, $stmt;
365 PTDEBUG && _d('Duration + statement');
366 }
367
368 else {
369 # The duration line is just junk. It's the line after a
370 # statement, but we never saw the statement (else we'd have
371 # fallen into 0xdeadbeef above). Discard this line and adjust
372 # pos_in_log. See t/samples/pg-log-002.txt for an example.
373 $first_line = undef;
374 ($pos_in_log, $line) = $self->get_line();
375 PTDEBUG && _d('Line applies to event we never saw, discarding');
376 next LINE;
377 }
378 }
379 else {
380 # This isn't a duration line, it's a statement or query. Put it
381 # onto @arg_lines for later and keep going.
382 push @arg_lines, $rest;
383 PTDEBUG && _d('Putting onto @arg_lines');
384 }
385 }
386
387 # Here is case 3, lines that can't be in case 1 or 2. These surely
388 # terminate any event that's been accumulated, and if there isn't any
389 # such, then we just create an event without the overhead of deferring.
390 else {
391 $done = 1;
392 PTDEBUG && _d('Line is case 3, event is done');
393
394 # Again, if there's previously gathered data in @arg_lines, we have
395 # to defer the current line (not touching @properties) and revisit it.
396 if ( @arg_lines ) {
397 $self->pending($new_pos, $line);
398 PTDEBUG && _d('There was @arg_lines, putting line to pending');
399 }
400
401 # Otherwise we can parse the line and put it into @properties.
402 else {
403 PTDEBUG && _d('No need to defer, process event from this line now');
404 push @properties, 'cmd', 'Admin', 'arg', $label;
405
406 # For some kinds of log lines, we can grab extra meta-data out of
407 # the end of the line.
408 # LOG: connection received: host=[local]
409 if ( $label =~ m/\A(?:dis)?connection(?: received| authorized)?\Z/ ) {
410 push @properties, $self->get_meta($rest);
411 }
412
413 else {
414 die "I don't understand line $line";
415 }
416
417 }
418 }
419
420 }
421
422 # If the line isn't case 1, 2, or 3 I don't know what it is.
423 else {
424 die "I don't understand line $line";
425 }
426
427 # We get the next line to process.
428 if ( !$done ) {
429 ($new_pos, $line) = $self->get_line();
430 }
431 } # LINE
432
433 # If we're at the end of the file, we finish and tell the caller we're done.
434 if ( !defined $line ) {
435 PTDEBUG && _d('Line not defined, at EOF; calling oktorun(0) if exists');
436 $args{oktorun}->(0) if $args{oktorun};
437 if ( !@arg_lines ) {
438 PTDEBUG && _d('No saved @arg_lines either, we are all done');
439 return undef;
440 }
441 }
442
443 # If we got kicked out of the while loop because of a non-LOG line, we handle
444 # that line here.
445 if ( $line_type && $line_type ne 'LOG' ) {
446 PTDEBUG && _d('Line is not a LOG line');
447
448 # ERROR lines come in a few flavors. See t/samples/pg-log-006.txt,
449 # t/samples/pg-syslog-002.txt, and t/samples/pg-syslog-007.txt for some
450 # examples. The rules seem to be this: if the ERROR is followed by a
451 # STATEMENT, and the STATEMENT's statement matches the query in
452 # @arg_lines, then the STATEMENT message is redundant. (This can be
453 # caused by various combos of configuration options in postgresql.conf).
454 # However, if the ERROR's STATEMENT line doesn't match what's in
455 # @arg_lines, then the ERROR actually starts a new event. If the ERROR is
456 # followed by another LOG event, then the ERROR also starts a new event.
457 if ( $line_type eq 'ERROR' ) {
458 PTDEBUG && _d('Line is ERROR');
459
460 # If there's already a statement in processing, then put aside the
461 # current line, and peek ahead.
462 if ( @arg_lines ) {
463 PTDEBUG && _d('There is @arg_lines, will peek ahead one line');
464 my ( $temp_pos, $temp_line ) = $self->get_line();
465 my ( $type, $msg );
466 if (
467 defined $temp_line
468 && ( ($type, $msg) = $temp_line =~ m/$log_line_regex(.*)/o )
469 && ( $type ne 'STATEMENT' || $msg eq $arg_lines[-1] )
470 ) {
471 # Looks like the whole thing is pertaining to the current event
472 # in progress. Add the error message to the event.
473 PTDEBUG && _d('Error/statement line pertain to current event');
474 push @properties, 'Error_msg', $line =~ m/ERROR:\s*(\S.*)\Z/s;
475 if ( $type ne 'STATEMENT' ) {
476 PTDEBUG && _d('Must save peeked line, it is a', $type);
477 $self->pending($temp_pos, $temp_line);
478 }
479 }
480 elsif ( defined $temp_line && defined $type ) {
481 # Looks like the current and next line are about a new event.
482 # Put them into pending.
483 PTDEBUG && _d('Error/statement line are a new event');
484 $self->pending($new_pos, $line);
485 $self->pending($temp_pos, $temp_line);
486 }
487 else {
488 PTDEBUG && _d("Unknown line", $line);
489 }
490 }
491 }
492 else {
493 PTDEBUG && _d("Unknown line", $line);
494 }
495 }
496
497 # If $done is true, then some of the above code decided that the full
498 # event has been found. If we reached the end of the file, then we might
499 # also have something in @arg_lines, although we didn't find the "line after"
500 # that signals the event was done. In either case we return an event. This
501 # should be the only 'return' statement in this block of code.
502 if ( $done || @arg_lines ) {
503 PTDEBUG && _d('Making event');
504
505 # Finish building the event.
506 push @properties, 'pos_in_log', $pos_in_log;
507
508 # Statement/query lines will be in @arg_lines.
509 if ( @arg_lines ) {
510 PTDEBUG && _d('Assembling @arg_lines: ', scalar @arg_lines);
511 push @properties, 'arg', join('', @arg_lines), 'cmd', 'Query';
512 }
513
514 if ( $first_line ) {
515 # Handle some meta-data: a timestamp, with optional milliseconds.
516 if ( my ($ts) = $first_line =~ m/([0-9-]{10} [0-9:.]{8,12})/ ) {
517 PTDEBUG && _d('Getting timestamp', $ts);
518 push @properties, 'ts', $ts;
519 }
520
521 # Find meta-data embedded in the log line prefix, in name=value format.
522 if ( my ($meta) = $first_line =~ m/(.*?)[A-Z]{3,}: / ) {
523 PTDEBUG && _d('Found a meta-data chunk:', $meta);
524 push @properties, $self->get_meta($meta);
525 }
526 }
527
528 # Dump info about what we've found, but don't dump $event; want to see
529 # full dump of all properties, and after it's been cast into a hash,
530 # duplicated keys will be gone.
531 PTDEBUG && _d('Properties of event:', Dumper(\@properties));
532 my $event = { @properties };
533 $event->{bytes} = length($event->{arg} || '');
534 return $event;
535 }
536
537}
538
539# Parses key=value meta-data from the $meta string, and returns a list of event
540# attribute names and values.
541sub get_meta {
542 my ( $self, $meta ) = @_;
543 my @properties;
544 foreach my $set ( $meta =~ m/(\w+=[^, ]+)/g ) {
545 my ($key, $val) = split(/=/, $set);
546 if ( $key && $val ) {
547 # The first letter of the name, lowercased, determines the
548 # meaning of the item.
549 if ( my $prop = $attrib_name_for{lc substr($key, 0, 1)} ) {
550 push @properties, $prop, $val;
551 }
552 else {
553 PTDEBUG && _d('Bad meta key', $set);
554 }
555 }
556 else {
557 PTDEBUG && _d("Can't figure out meta from", $set);
558 }
559 }
560 return @properties;
561}
562
563# This subroutine abstracts the process and source of getting a line of text and
564# its position in the log file. It might get the line of text from the log; it
565# might get it from the @pending array. It also does infinite loop checking
566# TODO.
567sub get_line {
568 my ( $self ) = @_;
569 my ($pos, $line, $was_pending) = $self->pending;
570 if ( ! defined $line ) {
571 PTDEBUG && _d('Got nothing from pending, trying the $fh');
572 my ( $next_event, $tell) = @{$self}{qw(next_event tell)};
573 eval {
574 $pos = $tell->();
575 $line = $next_event->();
576 };
577 if ( PTDEBUG && $EVAL_ERROR ) {
578 _d($EVAL_ERROR);
579 }
580 }
581
582 PTDEBUG && _d('Got pos/line:', $pos, $line);
583 return ($pos, $line);
584}
585
586# This subroutine defers and retrieves a line/pos pair. If you give it an
587# argument it'll set the stored value. If not, it'll get one if there is one
588# and return it.
589sub pending {
590 my ( $self, $val, $pos_in_log ) = @_;
591 my $was_pending;
592 PTDEBUG && _d('In sub pending, val:', $val);
593 if ( $val ) {
594 push @{$self->{pending}}, [$val, $pos_in_log];
595 }
596 elsif ( @{$self->{pending}} ) {
597 ($val, $pos_in_log) = @{ shift @{$self->{pending}} };
598 $was_pending = 1;
599 }
600 PTDEBUG && _d('Return from pending:', $val, $pos_in_log);
601 return ($val, $pos_in_log, $was_pending);
602}
603
604# This subroutine manufactures subroutines to automatically translate incoming
605# syslog format into standard log format, to keep the main parse_event free from
606# having to think about that. For documentation on how this works, see
607# SysLogParser.pm.
608sub generate_wrappers {
609 my ( $self, %args ) = @_;
610
611 # Reset everything, just in case some cruft was left over from a previous use
612 # of this object. The object has stateful closures. If this isn't done,
613 # then they'll keep reading from old filehandles. The sanity check is based
614 # on the memory address of the closure!
615 if ( ($self->{sanity} || '') ne "$args{next_event}" ){
616 PTDEBUG && _d("Clearing and recreating internal state");
617 eval { require SysLogParser; }; # Required for tests to work.
618 my $sl = new SysLogParser();
619
620 # We need a special item in %args for syslog parsing. (This might not be
621 # a syslog log file...) See the test for t/samples/pg-syslog-002.txt for
622 # an example of when this is needed.
623 $args{misc}->{new_event_test} = sub {
624 my ( $content ) = @_;
625 return unless defined $content;
626 return $content =~ m/$log_line_regex/o;
627 };
628
629 # The TAB at the beginning of the line indicates that there's a newline
630 # at the end of the previous line.
631 $args{misc}->{line_filter} = sub {
632 my ( $content ) = @_;
633 $content =~ s/\A\t/\n/;
634 return $content;
635 };
636
637 @{$self}{qw(next_event tell is_syslog)} = $sl->make_closures(%args);
638 $self->{sanity} = "$args{next_event}";
639 }
640
641 # Return the wrapper functions!
642 return @{$self}{qw(next_event tell is_syslog)};
643}
644
645# This subroutine converts various formats to seconds. Examples:
646# 10.870 ms
647sub duration_to_secs {
648 my ( $self, $str ) = @_;
649 PTDEBUG && _d('Duration:', $str);
650 my ( $num, $suf ) = split(/\s+/, $str);
651 my $factor = $suf eq 'ms' ? 1000
652 : $suf eq 'sec' ? 1
653 : die("Unknown suffix '$suf'");
654 return $num / $factor;
655}
656
657sub _d {
658 my ($package, undef, $line) = caller 0;
659 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
660 map { defined $_ ? $_ : 'undef' }
661 @_;
662 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
663}
664
6651;
666}
667# ###########################################################################
668# End PgLogParser package
669# ###########################################################################
6700
=== modified file 'lib/QueryReportFormatter.pm'
--- lib/QueryReportFormatter.pm 2013-01-31 17:52:34 +0000
+++ lib/QueryReportFormatter.pm 2013-02-01 18:19:34 +0000
@@ -481,9 +481,7 @@
481 }481 }
482482
483 my $log_type = $args{log_type} || '';483 my $log_type = $args{log_type} || '';
484 my $mark = $log_type eq 'memcached'484 my $mark = '\G';
485 || $log_type eq 'http'
486 || $log_type eq 'pglog' ? '' : '\G';
487485
488 if ( $item =~ m/^(?:[\(\s]*select|insert|replace)/ ) {486 if ( $item =~ m/^(?:[\(\s]*select|insert|replace)/ ) {
489 if ( $item =~ m/^(?:insert|replace)/ ) { # No EXPLAIN487 if ( $item =~ m/^(?:insert|replace)/ ) { # No EXPLAIN
490488
=== removed file 'lib/SysLogParser.pm'
--- lib/SysLogParser.pm 2013-01-03 00:19:16 +0000
+++ lib/SysLogParser.pm 1970-01-01 00:00:00 +0000
@@ -1,259 +0,0 @@
1# This program is copyright 2010-2011 Baron Schwartz, 2011 Percona Ireland Ltd.
2# Feedback and improvements are welcome.
3#
4# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
5# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
7#
8# This program is free software; you can redistribute it and/or modify it under
9# the terms of the GNU General Public License as published by the Free Software
10# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
11# systems, you can issue `man perlgpl' or `man perlartistic' to read these
12# licenses.
13#
14# You should have received a copy of the GNU General Public License along with
15# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
16# Place, Suite 330, Boston, MA 02111-1307 USA.
17# ###########################################################################
18# SysLogParser package
19# ###########################################################################
20{
21# Package: SysLogParser
22# SysLogParser parses events from syslogs.
23package SysLogParser;
24
25use strict;
26use warnings FATAL => 'all';
27use English qw(-no_match_vars);
28use constant PTDEBUG => $ENV{PTDEBUG} || 0;
29
30# This regex matches the message number, line number, and content of a syslog
31# message:
32# 2008 Jan 9 16:16:34 hostname postgres[30059]: [13-2] ...content...
33my $syslog_regex = qr{\A.*\w+\[\d+\]: \[(\d+)-(\d+)\] (.*)\Z};
34
35# This class generates currying functions that wrap around a standard
36# log-parser's next_event() and tell() function pointers. The wrappers behave
37# the same way, except that they'll return entire syslog events, instead of
38# lines at a time. To use it, do the following:
39#
40# sub parse_event {
41# my ($self, %args) = @_;
42# my ($next_event, $tell, $is_syslog) = SysLogParser::make_closures(%args);
43# # ... write your code to use the $next_event and $tell here...
44# }
45#
46# If the log isn't in syslog format, $is_syslog will be false and you'll get
47# back simple wrappers around the $next_event and $tell functions. (They still
48# have to be wrapped, because to find out whether the log is in syslog format,
49# the first line has to be examined.)
50sub new {
51 my ( $class ) = @_;
52 my $self = {};
53 return bless $self, $class;
54}
55
56# This method is here so that SysLogParser can be used and tested in its own
57# right. However, its ability to generate wrapper functions probably means that
58# it should be used as a translation layer, not directly. You can use this code
59# as an example of how to integrate this into other packages.
60sub parse_event {
61 my ( $self, %args ) = @_;
62 my ( $next_event, $tell, $is_syslog ) = $self->generate_wrappers(%args);
63 return $next_event->();
64}
65
66# This is an example of how a class can seamlessly put a syslog translation
67# layer underneath itself.
68sub generate_wrappers {
69 my ( $self, %args ) = @_;
70
71 # Reset everything, just in case some cruft was left over from a previous use
72 # of this object. The object has stateful closures. If this isn't done,
73 # then they'll keep reading from old filehandles. The sanity check is based
74 # on the memory address of the closure!
75 if ( ($self->{sanity} || '') ne "$args{next_event}" ){
76 PTDEBUG && _d("Clearing and recreating internal state");
77 @{$self}{qw(next_event tell is_syslog)} = $self->make_closures(%args);
78 $self->{sanity} = "$args{next_event}";
79 }
80
81 # Return the wrapper functions!
82 return @{$self}{qw(next_event tell is_syslog)};
83}
84
85# Make the closures! The $args{misc}->{new_event_test} is an optional
86# subroutine reference, which tells the wrapper when to consider a line part of
87# a new event, in syslog format, even when it's technically the same syslog
88# event. See the test for samples/pg-syslog-002.txt for an example. This
89# argument should be passed in via the call to parse_event(). Ditto for
90# 'line_filter', which is some processing code to run on every line of content
91# in an event.
92sub make_closures {
93 my ( $self, %args ) = @_;
94
95 # The following variables will be referred to in the manufactured
96 # subroutines, making them proper closures.
97 my $next_event = $args{'next_event'};
98 my $tell = $args{'tell'};
99 my $new_event_test = $args{'misc'}->{'new_event_test'};
100 my $line_filter = $args{'misc'}->{'line_filter'};
101
102 # The first thing to do is get a line from the log and see if it's from
103 # syslog.
104 my $test_line = $next_event->();
105 PTDEBUG && _d('Read first sample/test line:', $test_line);
106
107 # If it's syslog, we have to generate a moderately elaborate wrapper
108 # function.
109 if ( defined $test_line && $test_line =~ m/$syslog_regex/o ) {
110
111 # Within syslog-parsing subroutines, we'll use LLSP (low-level syslog
112 # parser) as a PTDEBUG line prefix.
113 PTDEBUG && _d('This looks like a syslog line, PTDEBUG prefix=LLSP');
114
115 # Grab the interesting bits out of the test line, and save the result.
116 my ($msg_nr, $line_nr, $content) = $test_line =~ m/$syslog_regex/o;
117 my @pending = ($test_line);
118 my $last_msg_nr = $msg_nr;
119 my $pos_in_log = 0;
120
121 # Generate the subroutine for getting a full log message without syslog
122 # breaking it across multiple lines.
123 my $new_next_event = sub {
124 PTDEBUG && _d('LLSP: next_event()');
125
126 # Keeping the pos_in_log variable right is a bit tricky! In general,
127 # we have to tell() the filehandle before trying to read from it,
128 # getting the position before the data we've just read. The simple
129 # rule is that when we push something onto @pending, which we almost
130 # always do, then $pos_in_log should point to the beginning of that
131 # saved content in the file.
132 PTDEBUG && _d('LLSP: Current virtual $fh position:', $pos_in_log);
133 my $new_pos = 0;
134
135 # @arg_lines is where we store up the content we're about to return.
136 # It contains $content; @pending contains a single saved $line.
137 my @arg_lines;
138
139 # Here we actually examine lines until we have found a complete event.
140 my $line;
141 LINE:
142 while (
143 defined($line = shift @pending)
144 || do {
145 # Save $new_pos, because when we hit EOF we can't $tell->()
146 # anymore.
147 eval { $new_pos = -1; $new_pos = $tell->() };
148 defined($line = $next_event->());
149 }
150 ) {
151 PTDEBUG && _d('LLSP: Line:', $line);
152
153 # Parse the line.
154 ($msg_nr, $line_nr, $content) = $line =~ m/$syslog_regex/o;
155 if ( !$msg_nr ) {
156 die "Can't parse line: $line";
157 }
158
159 # The message number has changed -- thus, new message.
160 elsif ( $msg_nr != $last_msg_nr ) {
161 PTDEBUG && _d('LLSP: $msg_nr', $last_msg_nr, '=>', $msg_nr);
162 $last_msg_nr = $msg_nr;
163 last LINE;
164 }
165
166 # Or, the caller gave us a custom new_event_test and it is true --
167 # thus, also new message.
168 elsif ( @arg_lines && $new_event_test && $new_event_test->($content) ) {
169 PTDEBUG && _d('LLSP: $new_event_test matches');
170 last LINE;
171 }
172
173 # Otherwise it's part of the current message; put it onto the list
174 # of lines pending. We have to translate characters that syslog has
175 # munged. Some translate TAB into the literal characters '^I' and
176 # some, rsyslog on Debian anyway, seem to translate all whitespace
177 # control characters into an octal string representing the character
178 # code.
179 # Example: #011FROM pg_catalog.pg_class c
180 $content =~ s/#(\d{3})/chr(oct($1))/ge;
181 $content =~ s/\^I/\t/g;
182 if ( $line_filter ) {
183 PTDEBUG && _d('LLSP: applying $line_filter');
184 $content = $line_filter->($content);
185 }
186
187 push @arg_lines, $content;
188 }
189 PTDEBUG && _d('LLSP: Exited while-loop after finding a complete entry');
190
191 # Mash the pending stuff together to return it.
192 my $psql_log_event = @arg_lines ? join('', @arg_lines) : undef;
193 PTDEBUG && _d('LLSP: Final log entry:', $psql_log_event);
194
195 # Save the new content into @pending for the next time. $pos_in_log
196 # must also be updated to whatever $new_pos is.
197 if ( defined $line ) {
198 PTDEBUG && _d('LLSP: Saving $line:', $line);
199 @pending = $line;
200 PTDEBUG && _d('LLSP: $pos_in_log:', $pos_in_log, '=>', $new_pos);
201 $pos_in_log = $new_pos;
202 }
203 else {
204 # We hit the end of the file.
205 PTDEBUG && _d('LLSP: EOF reached');
206 @pending = ();
207 $last_msg_nr = 0;
208 }
209
210 return $psql_log_event;
211 };
212
213 # Create the closure for $tell->();
214 my $new_tell = sub {
215 PTDEBUG && _d('LLSP: tell()', $pos_in_log);
216 return $pos_in_log;
217 };
218
219 return ($new_next_event, $new_tell, 1);
220 }
221
222 # This is either at EOF already, or it's not syslog format.
223 else {
224
225 # Within plain-log-parsing subroutines, we'll use PLAIN as a PTDEBUG
226 # line prefix.
227 PTDEBUG && _d('Plain log, or we are at EOF; PTDEBUG prefix=PLAIN');
228
229 # The @pending array is really only needed to return the one line we
230 # already read as a test. Too bad we can't just push it back onto the
231 # log. TODO: maybe we can test whether the filehandle is seekable and
232 # seek back to the start, then just return the unwrapped functions?
233 my @pending = defined $test_line ? ($test_line) : ();
234
235 my $new_next_event = sub {
236 PTDEBUG && _d('PLAIN: next_event(); @pending:', scalar @pending);
237 return @pending ? shift @pending : $next_event->();
238 };
239 my $new_tell = sub {
240 PTDEBUG && _d('PLAIN: tell(); @pending:', scalar @pending);
241 return @pending ? 0 : $tell->();
242 };
243 return ($new_next_event, $new_tell, 0);
244 }
245}
246
247sub _d {
248 my ($package, undef, $line) = caller 0;
249 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
250 map { defined $_ ? $_ : 'undef' }
251 @_;
252 print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
253}
254
2551;
256}
257# ###########################################################################
258# End SysLogParser package
259# ###########################################################################
2600
=== modified file 'lib/TcpdumpParser.pm'
--- lib/TcpdumpParser.pm 2013-01-03 00:19:16 +0000
+++ lib/TcpdumpParser.pm 2013-02-01 18:19:34 +0000
@@ -172,10 +172,7 @@
172sub port_number {172sub port_number {
173 my ( $self, $port ) = @_;173 my ( $self, $port ) = @_;
174 return unless $port;174 return unless $port;
175 return $port eq 'memcached' ? 11211175 return $port eq 'mysql' ? 3306 : $port;
176 : $port eq 'http' ? 80
177 : $port eq 'mysql' ? 3306
178 : $port;
179}176}
180177
181sub _d {178sub _d {
182179
=== removed file 't/lib/HTTPProtocolParser.t'
--- t/lib/HTTPProtocolParser.t 2012-03-06 13:56:08 +0000
+++ t/lib/HTTPProtocolParser.t 1970-01-01 00:00:00 +0000
@@ -1,286 +0,0 @@
1#!/usr/bin/perl
2
3BEGIN {
4 die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n"
5 unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH};
6 unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib";
7};
8
9use strict;
10use warnings FATAL => 'all';
11use English qw(-no_match_vars);
12use Test::More tests => 16;
13
14use TcpdumpParser;
15use ProtocolParser;
16use HTTPProtocolParser;
17use PerconaTest;
18
19my $tcpdump = new TcpdumpParser();
20my $protocol; # Create a new HTTPProtocolParser for each test.
21
22# GET a very simple page.
23$protocol = new HTTPProtocolParser();
24test_protocol_parser(
25 parser => $tcpdump,
26 protocol => $protocol,
27 file => 't/lib/samples/http/http_tcpdump001.txt',
28 result => [
29 { ts => '2009-11-09 11:31:52.341907',
30 bytes => '715',
31 host => '10.112.2.144',
32 pos_in_log => 0,
33 Virtual_host => 'hackmysql.com',
34 arg => 'get hackmysql.com/contact',
35 Status_code => '200',
36 Query_time => '0.651419',
37 Transmit_time => '0.000000',
38 },
39 ],
40);
41
42# Get http://www.percona.com/about-us.html
43$protocol = new HTTPProtocolParser();
44test_protocol_parser(
45 parser => $tcpdump,
46 protocol => $protocol,
47 file => 't/lib/samples/http/http_tcpdump002.txt',
48 result => [
49 {
50 ts => '2009-11-09 15:31:09.074855',
51 Query_time => '0.070097',
52 Status_code => '200',
53 Transmit_time => '0.000720',
54 Virtual_host => 'www.percona.com',
55 arg => 'get www.percona.com/about-us.html',
56 bytes => 3832,
57 host => '10.112.2.144',
58 pos_in_log => 206,
59 },
60 {
61 ts => '2009-11-09 15:31:09.157215',
62 Query_time => '0.068558',
63 Status_code => '200',
64 Transmit_time => '0.066490',
65 Virtual_host => 'www.percona.com',
66 arg => 'get www.percona.com/js/jquery.js',
67 bytes => 9921,
68 host => '10.112.2.144',
69 pos_in_log => 16362,
70 },
71 {
72 ts => '2009-11-09 15:31:09.346763',
73 Query_time => '0.066506',
74 Status_code => '200',
75 Transmit_time => '0.000000',
76 Virtual_host => 'www.percona.com',
77 arg => 'get www.percona.com/images/menu_team.gif',
78 bytes => 344,
79 host => '10.112.2.144',
80 pos_in_log => 53100,
81 },
82 {
83 ts => '2009-11-09 15:31:09.373800',
84 Query_time => '0.045442',
85 Status_code => '200',
86 Transmit_time => '0.000000',
87 Virtual_host => 'www.google-analytics.com',
88 arg => 'get www.google-analytics.com/__utm.gif?utmwv=1.3&utmn=1710381507&utmcs=UTF-8&utmsr=1280x800&utmsc=24-bit&utmul=en-us&utmje=1&utmfl=10.0%20r22&utmdt=About%20Percona&utmhn=www.percona.com&utmhid=1947703805&utmr=0&utmp=/about-us.html&utmac=UA-343802-3&utmcc=__utma%3D154442809.1969570579.1256593671.1256825719.1257805869.3%3B%2B__utmz%3D154442809.1256593671.1.1.utmccn%3D(direct)%7Cutmcsr%3D(direct)%7Cutmcmd%3D(none)%3B%2B',
89 bytes => 35,
90 host => '10.112.2.144',
91 pos_in_log => 55942,
92 },
93 {
94 ts => '2009-11-09 15:31:09.411349',
95 Query_time => '0.073882',
96 Status_code => '200',
97 Transmit_time => '0.000000',
98 Virtual_host => 'www.percona.com',
99 arg => 'get www.percona.com/images/menu_our-vision.gif',
100 bytes => 414,
101 host => '10.112.2.144',
102 pos_in_log => 59213,
103 },
104 {
105 ts => '2009-11-09 15:31:09.420851',
106 Query_time => '0.067669',
107 Status_code => '200',
108 Transmit_time => '0.000000',
109 Virtual_host => 'www.percona.com',
110 arg => 'get www.percona.com/images/bg-gray-corner-top.gif',
111 bytes => 170,
112 host => '10.112.2.144',
113 pos_in_log => 65644,
114 },
115 {
116 ts => '2009-11-09 15:31:09.420996',
117 Query_time => '0.067345',
118 Status_code => '200',
119 Transmit_time => '0.134909',
120 Virtual_host => 'www.percona.com',
121 arg => 'get www.percona.com/images/handshake.jpg',
122 bytes => 20017,
123 host => '10.112.2.144',
124 pos_in_log => 67956,
125 },
126 {
127 ts => '2009-11-09 15:31:14.536149',
128 Query_time => '0.061528',
129 Status_code => '200',
130 Transmit_time => '0.059577',
131 Virtual_host => 'hit.clickaider.com',
132 arg => 'get hit.clickaider.com/clickaider.js',
133 bytes => 4009,
134 host => '10.112.2.144',
135 pos_in_log => 147447,
136 },
137 {
138 ts => '2009-11-09 15:31:14.678713',
139 Query_time => '0.060436',
140 Status_code => '200',
141 Transmit_time => '0.000000',
142 Virtual_host => 'hit.clickaider.com',
143 arg => 'get hit.clickaider.com/pv?lng=140&&lnks=&t=About%20Percona&c=73a41b95-2926&r=http%3A%2F%2Fwww.percona.com%2F&tz=-420&loc=http%3A%2F%2Fwww.percona.com%2Fabout-us.html&rnd=3688',
144 bytes => 43,
145 host => '10.112.2.144',
146 pos_in_log => 167245,
147 },
148 {
149 ts => '2009-11-09 15:31:14.737890',
150 Query_time => '0.061937',
151 Status_code => '200',
152 Transmit_time => '0.000000',
153 Virtual_host => 'hit.clickaider.com',
154 arg => 'get hit.clickaider.com/s/forms.js',
155 bytes => 822,
156 host => '10.112.2.144',
157 pos_in_log => 170117,
158 },
159 ],
160);
161
162# A reponse received in out of order packet.
163$protocol = new HTTPProtocolParser();
164test_protocol_parser(
165 parser => $tcpdump,
166 protocol => $protocol,
167 file => 't/lib/samples/http/http_tcpdump004.txt',
168 result => [
169 { ts => '2009-11-12 11:27:10.757573',
170 Query_time => '0.327356',
171 Status_code => '200',
172 Transmit_time => '0.549501',
173 Virtual_host => 'dev.mysql.com',
174 arg => 'get dev.mysql.com/common/css/mysql.css',
175 bytes => 11283,
176 host => '10.67.237.92',
177 pos_in_log => 776,
178 },
179 ],
180);
181
182# A client request broken over 2 packets.
183$protocol = new HTTPProtocolParser();
184test_protocol_parser(
185 parser => $tcpdump,
186 protocol => $protocol,
187 file => 't/lib/samples/http/http_tcpdump005.txt',
188 result => [
189 { ts => '2009-11-13 09:20:31.041924',
190 Query_time => '0.342166',
191 Status_code => '200',
192 Transmit_time => '0.012780',
193 Virtual_host => 'dev.mysql.com',
194 arg => 'get dev.mysql.com/doc/refman/5.0/fr/retrieving-data.html',
195 bytes => 4382,
196 host => '192.168.200.110',
197 pos_in_log => 785,
198 },
199 ],
200);
201
202# Out of order header that might look like the text header
203# but is really data; text header arrives last.
204$protocol = new HTTPProtocolParser();
205test_protocol_parser(
206 parser => $tcpdump,
207 protocol => $protocol,
208 file => 't/lib/samples/http/http_tcpdump006.txt',
209 result => [
210 { ts => '2009-11-13 09:50:44.432099',
211 Query_time => '0.140878',
212 Status_code => '200',
213 Transmit_time => '0.237153',
214 Virtual_host => '247wallst.files.wordpress.com',
215 arg => 'get 247wallst.files.wordpress.com/2009/11/airplane4.jpg?w=139&h=93',
216 bytes => 3391,
217 host => '192.168.200.110',
218 pos_in_log => 782,
219 },
220 ],
221);
222
223# One 2.6M image that took almost a minute to load (very slow wifi).
224$protocol = new HTTPProtocolParser();
225test_protocol_parser(
226 parser => $tcpdump,
227 protocol => $protocol,
228 file => 't/lib/samples/http/http_tcpdump007.txt',
229 result => [
230 { ts => '2009-11-13 10:09:53.251620',
231 Query_time => '0.121971',
232 Status_code => '200',
233 Transmit_time => '40.311228',
234 Virtual_host => 'apod.nasa.gov',
235 arg => 'get apod.nasa.gov/apod/image/0911/Ophcloud_spitzer.jpg',
236 bytes => 2706737,
237 host => '192.168.200.110',
238 pos_in_log => 640,
239 }
240 ],
241);
242
243# A simple POST.
244$protocol = new HTTPProtocolParser();
245test_protocol_parser(
246 parser => $tcpdump,
247 protocol => $protocol,
248 file => 't/lib/samples/http/http_tcpdump008.txt',
249 result => [
250 { ts => '2009-11-13 10:53:48.349465',
251 Query_time => '0.030740',
252 Status_code => '200',
253 Transmit_time => '0.000000',
254 Virtual_host => 'www.google.com',
255 arg => 'post www.google.com/finance/qs/channel?VER=6&RID=481&CVER=1&zx=5xccsz-eg9chk&t=1',
256 bytes => 54,
257 host => '192.168.200.110',
258 pos_in_log => 0,
259 }
260 ],
261);
262
263# .http instead of .80
264$protocol = new HTTPProtocolParser();
265test_protocol_parser(
266 parser => $tcpdump,
267 protocol => $protocol,
268 file => 't/lib/samples/http/http_tcpdump009.txt',
269 result => [
270 { ts => '2009-11-09 11:31:52.341907',
271 bytes => '715',
272 host => '10.112.2.144',
273 pos_in_log => 0,
274 Virtual_host => 'hackmysql.com',
275 arg => 'get hackmysql.com/contact',
276 Status_code => '200',
277 Query_time => '0.651419',
278 Transmit_time => '0.000000',
279 },
280 ],
281);
282
283# #############################################################################
284# Done.
285# #############################################################################
286exit;
2870
=== removed file 't/lib/MemcachedEvent.t'
--- t/lib/MemcachedEvent.t 2012-03-06 13:56:08 +0000
+++ t/lib/MemcachedEvent.t 1970-01-01 00:00:00 +0000
@@ -1,766 +0,0 @@
1#!/usr/bin/perl
2
3BEGIN {
4 die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n"
5 unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH};
6 unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib";
7};
8
9use strict;
10use warnings FATAL => 'all';
11use English qw(-no_match_vars);
12use Test::More tests => 15;
13
14use MemcachedEvent;
15use PerconaTest;
16
17my $memce = new MemcachedEvent();
18isa_ok($memce, 'MemcachedEvent');
19
20sub make_events {
21 my ( @memc_events ) = @_;
22 my @events;
23 push @events, map { $memce->parse_event(event=>$_) } @memc_events;
24 return \@events;
25}
26
27# #############################################################################
28# Sanity tests.
29# #############################################################################
30my $events = make_events(
31 {
32 key => 'my_key',
33 val => 'Some value',
34 res => 'STORED',
35 Query_time => 1,
36 },
37);
38is_deeply(
39 $events,
40 [],
41 "Doesn't die when there's no cmd"
42);
43
44$events = make_events(
45 {
46 cmd => 'unknown_cmd',
47 val => 'Some value',
48 res => 'STORED',
49 Query_time => 1,
50 },
51);
52is_deeply(
53 $events,
54 [],
55 "Doesn't die when there's no key"
56);
57
58$events = make_events(
59 {
60 val => 'Some value',
61 res => 'STORED',
62 Query_time => 1,
63 },
64);
65is_deeply(
66 $events,
67 [],
68 "Doesn't die when there's no cmd or key"
69);
70
71$events = make_events(
72 {
73 cmd => 'unknown_cmd',
74 key => 'my_key',
75 val => 'Some value',
76 res => 'STORED',
77 Query_time => 1,
78 },
79);
80is_deeply(
81 $events,
82 [],
83 "Doesn't handle unknown cmd"
84);
85
86# #############################################################################
87# These events are copied straight from the expected results in
88# MemcachedProtocolParser.t.
89# #############################################################################
90
91# A session with a simple set().
92$events = make_events(
93 { ts => '2009-07-04 21:33:39.229179',
94 host => '127.0.0.1',
95 cmd => 'set',
96 key => 'my_key',
97 val => 'Some value',
98 flags => '0',
99 exptime => '0',
100 bytes => '10',
101 res => 'STORED',
102 Query_time => sprintf('%.6f', .229299 - .229179),
103 pos_in_log => 0,
104 },
105);
106is_deeply(
107 $events,
108 [
109 {
110 arg => 'set my_key',
111 fingerprint => 'set my_key',
112 key_print => 'my_key',
113 cmd => 'set',
114 key => 'my_key',
115 res => 'STORED',
116 Memc_add => 'No',
117 Memc_append => 'No',
118 Memc_cas => 'No',
119 Memc_decr => 'No',
120 Memc_delete => 'No',
121 Memc_error => 'No',
122 Memc_get => 'No',
123 Memc_gets => 'No',
124 Memc_incr => 'No',
125 Memc_miss => 'No',
126 Memc_prepend => 'No',
127 Memc_replace => 'No',
128 Memc_set => 'Yes',
129 Memc_miss => 'No',
130 Memc_error => 'No',
131 Memc_Not_Stored => 'No',
132 Memc_Exists => 'No',
133 Query_time => '0.000120',
134 bytes => '10',
135 exptime => '0',
136 fingerprint => 'set my_key',
137 flags => '0',
138 host => '127.0.0.1',
139 pos_in_log => 0,
140 ts => '2009-07-04 21:33:39.229179',
141 val => 'Some value'
142 },
143 ],
144 'samples/memc_tcpdump001.txt: simple set'
145);
146
147# A session with a simple get().
148$events = make_events(
149 { Query_time => '0.000067',
150 cmd => 'get',
151 key => 'my_key',
152 val => 'Some value',
153 bytes => 10,
154 exptime => undef,
155 flags => 0,
156 host => '127.0.0.1',
157 pos_in_log => '0',
158 res => 'VALUE',
159 ts => '2009-07-04 22:12:06.174390'
160 }
161);
162is_deeply(
163 $events,
164 [
165 {
166 arg => 'get my_key',
167 fingerprint => 'get my_key',
168 key_print => 'my_key',
169 cmd => 'get',
170 key => 'my_key',
171 res => 'VALUE',
172 Memc_add => 'No',
173 Memc_append => 'No',
174 Memc_cas => 'No',
175 Memc_decr => 'No',
176 Memc_delete => 'No',
177 Memc_error => 'No',
178 Memc_get => 'Yes',
179 Memc_gets => 'No',
180 Memc_incr => 'No',
181 Memc_miss => 'No',
182 Memc_prepend => 'No',
183 Memc_replace => 'No',
184 Memc_set => 'No',
185 Memc_miss => 'No',
186 Memc_error => 'No',
187 Query_time => '0.000067',
188 val => 'Some value',
189 bytes => 10,
190 exptime => undef,
191 flags => 0,
192 host => '127.0.0.1',
193 pos_in_log => '0',
194 ts => '2009-07-04 22:12:06.174390'
195 },
196 ],
197 'samples/memc_tcpdump002.txt: simple get',
198);
199
200# A session with a simple incr() and decr().
201$events = make_events(
202 { Query_time => '0.000073',
203 cmd => 'incr',
204 key => 'key',
205 val => '8',
206 bytes => undef,
207 exptime => undef,
208 flags => undef,
209 host => '127.0.0.1',
210 pos_in_log => '0',
211 res => '',
212 ts => '2009-07-04 22:12:06.175734',
213 },
214 { Query_time => '0.000068',
215 cmd => 'decr',
216 bytes => undef,
217 exptime => undef,
218 flags => undef,
219 host => '127.0.0.1',
220 key => 'key',
221 pos_in_log => 522,
222 res => '',
223 ts => '2009-07-04 22:12:06.176181',
224 val => '7',
225 },
226);
227is_deeply(
228 $events,
229 [
230 {
231 arg => 'incr key',
232 fingerprint => 'incr key',
233 key_print => 'key',
234 cmd => 'incr',
235 key => 'key',
236 res => '',
237 Memc_add => 'No',
238 Memc_append => 'No',
239 Memc_cas => 'No',
240 Memc_decr => 'No',
241 Memc_delete => 'No',
242 Memc_error => 'No',
243 Memc_get => 'No',
244 Memc_gets => 'No',
245 Memc_incr => 'Yes',
246 Memc_miss => 'No',
247 Memc_prepend => 'No',
248 Memc_replace => 'No',
249 Memc_set => 'No',
250 Memc_miss => 'No',
251 Memc_error => 'No',
252 Query_time => '0.000073',
253 val => '8',
254 bytes => undef,
255 exptime => undef,
256 flags => undef,
257 host => '127.0.0.1',
258 pos_in_log => '0',
259 ts => '2009-07-04 22:12:06.175734',
260 },
261 {
262 arg => 'decr key',
263 fingerprint => 'decr key',
264 key_print => 'key',
265 cmd => 'decr',
266 key => 'key',
267 res => '',
268 Memc_add => 'No',
269 Memc_append => 'No',
270 Memc_cas => 'No',
271 Memc_decr => 'Yes',
272 Memc_delete => 'No',
273 Memc_error => 'No',
274 Memc_get => 'No',
275 Memc_gets => 'No',
276 Memc_incr => 'No',
277 Memc_miss => 'No',
278 Memc_prepend => 'No',
279 Memc_replace => 'No',
280 Memc_set => 'No',
281 Memc_miss => 'No',
282 Memc_error => 'No',
283 Query_time => '0.000068',
284 bytes => undef,
285 exptime => undef,
286 flags => undef,
287 host => '127.0.0.1',
288 pos_in_log => 522,
289 ts => '2009-07-04 22:12:06.176181',
290 val => '7',
291 },
292 ],
293 'samples/memc_tcpdump003.txt: incr and decr'
294);
295
296# A session with a simple incr() and decr(), but the value doesn't exist.
297$events = make_events(
298 { Query_time => '0.000131',
299 bytes => undef,
300 cmd => 'incr',
301 exptime => undef,
302 flags => undef,
303 host => '127.0.0.1',
304 key => 'key',
305 pos_in_log => 764,
306 res => 'NOT_FOUND',
307 ts => '2009-07-06 10:37:21.668469',
308 val => '',
309 },
310 {
311 Query_time => '0.000055',
312 bytes => undef,
313 cmd => 'decr',
314 exptime => undef,
315 flags => undef,
316 host => '127.0.0.1',
317 key => 'key',
318 pos_in_log => 1788,
319 res => 'NOT_FOUND',
320 ts => '2009-07-06 10:37:21.668851',
321 val => '',
322 },
323);
324is_deeply(
325 $events,
326 [
327 {
328 arg => 'incr key',
329 fingerprint => 'incr key',
330 key_print => 'key',
331 cmd => 'incr',
332 key => 'key',
333 res => 'NOT_FOUND',
334 Memc_add => 'No',
335 Memc_append => 'No',
336 Memc_cas => 'No',
337 Memc_decr => 'No',
338 Memc_delete => 'No',
339 Memc_error => 'No',
340 Memc_get => 'No',
341 Memc_gets => 'No',
342 Memc_incr => 'Yes',
343 Memc_miss => 'No',
344 Memc_prepend => 'No',
345 Memc_replace => 'No',
346 Memc_set => 'No',
347 Memc_miss => 'Yes',
348 Memc_error => 'No',
349 Query_time => '0.000131',
350 bytes => undef,
351 exptime => undef,
352 flags => undef,
353 host => '127.0.0.1',
354 pos_in_log => 764,
355 ts => '2009-07-06 10:37:21.668469',
356 val => '',
357 },
358 {
359 arg => 'decr key',
360 fingerprint => 'decr key',
361 key_print => 'key',
362 cmd => 'decr',
363 key => 'key',
364 res => 'NOT_FOUND',
365 Memc_add => 'No',
366 Memc_append => 'No',
367 Memc_cas => 'No',
368 Memc_decr => 'Yes',
369 Memc_delete => 'No',
370 Memc_error => 'No',
371 Memc_get => 'No',
372 Memc_gets => 'No',
373 Memc_incr => 'No',
374 Memc_miss => 'No',
375 Memc_prepend => 'No',
376 Memc_replace => 'No',
377 Memc_set => 'No',
378 Memc_miss => 'Yes',
379 Memc_error => 'No',
380 Query_time => '0.000055',
381 bytes => undef,
382 exptime => undef,
383 flags => undef,
384 host => '127.0.0.1',
385 pos_in_log => 1788,
386 ts => '2009-07-06 10:37:21.668851',
387 val => '',
388 },
389 ],
390 'samples/memc_tcpdump004.txt: incr and decr nonexistent key'
391);
392
393# A session with a huge set() that will not fit into a single TCP packet.
394$events = make_events(
395 { Query_time => '0.003928',
396 bytes => 17946,
397 cmd => 'set',
398 exptime => 0,
399 flags => 0,
400 host => '127.0.0.1',
401 key => 'my_key',
402 pos_in_log => 764,
403 res => 'STORED',
404 ts => '2009-07-06 22:07:14.406827',
405 val => ('lorem ipsum dolor sit amet' x 690) . ' fini!',
406 },
407);
408is_deeply(
409 $events,
410 [
411 {
412 arg => 'set my_key',
413 fingerprint => 'set my_key',
414 key_print => 'my_key',
415 cmd => 'set',
416 key => 'my_key',
417 res => 'STORED',
418 Memc_add => 'No',
419 Memc_append => 'No',
420 Memc_cas => 'No',
421 Memc_decr => 'No',
422 Memc_delete => 'No',
423 Memc_error => 'No',
424 Memc_get => 'No',
425 Memc_gets => 'No',
426 Memc_incr => 'No',
427 Memc_miss => 'No',
428 Memc_prepend => 'No',
429 Memc_replace => 'No',
430 Memc_set => 'Yes',
431 Memc_miss => 'No',
432 Memc_error => 'No',
433 Memc_Not_Stored => 'No',
434 Memc_Exists => 'No',
435 Query_time => '0.003928',
436 bytes => 17946,
437 exptime => 0,
438 flags => 0,
439 host => '127.0.0.1',
440 pos_in_log => 764,
441 ts => '2009-07-06 22:07:14.406827',
442 val => ('lorem ipsum dolor sit amet' x 690) . ' fini!',
443 },
444 ],
445 'samples/memc_tcpdump005.txt: huge set'
446);
447
448# A session with a huge get() that will not fit into a single TCP packet.
449$events = make_events(
450 {
451 Query_time => '0.000196',
452 bytes => 17946,
453 cmd => 'get',
454 exptime => undef,
455 flags => 0,
456 host => '127.0.0.1',
457 key => 'my_key',
458 pos_in_log => 0,
459 res => 'VALUE',
460 ts => '2009-07-06 22:07:14.411331',
461 val => ('lorem ipsum dolor sit amet' x 690) . ' fini!',
462 },
463);
464is_deeply(
465 $events,
466 [
467 {
468 arg => 'get my_key',
469 fingerprint => 'get my_key',
470 key_print => 'my_key',
471 cmd => 'get',
472 key => 'my_key',
473 res => 'VALUE',
474 Memc_add => 'No',
475 Memc_append => 'No',
476 Memc_cas => 'No',
477 Memc_decr => 'No',
478 Memc_delete => 'No',
479 Memc_error => 'No',
480 Memc_get => 'Yes',
481 Memc_gets => 'No',
482 Memc_incr => 'No',
483 Memc_miss => 'No',
484 Memc_prepend => 'No',
485 Memc_replace => 'No',
486 Memc_set => 'No',
487 Memc_miss => 'No',
488 Memc_error => 'No',
489 Query_time => '0.000196',
490 bytes => 17946,
491 exptime => undef,
492 flags => 0,
493 host => '127.0.0.1',
494 pos_in_log => 0,
495 ts => '2009-07-06 22:07:14.411331',
496 val => ('lorem ipsum dolor sit amet' x 690) . ' fini!',
497 },
498 ],
499 'samples/memc_tcpdump006.txt: huge get'
500);
501
502# A session with a get() that doesn't exist.
503$events = make_events(
504 {
505 Query_time => '0.000016',
506 bytes => undef,
507 cmd => 'get',
508 exptime => undef,
509 flags => undef,
510 host => '127.0.0.1',
511 key => 'comment_v3_482685',
512 pos_in_log => 0,
513 res => 'NOT_FOUND',
514 ts => '2009-06-11 21:54:49.059144',
515 val => '',
516 },
517);
518is_deeply(
519 $events,
520 [
521 {
522 arg => 'get comment_v3_482685',
523 fingerprint => 'get comment_v?_?',
524 key_print => 'comment_v?_?',
525 cmd => 'get',
526 key => 'comment_v3_482685',
527 res => 'NOT_FOUND',
528 Memc_add => 'No',
529 Memc_append => 'No',
530 Memc_cas => 'No',
531 Memc_decr => 'No',
532 Memc_delete => 'No',
533 Memc_error => 'No',
534 Memc_get => 'Yes',
535 Memc_gets => 'No',
536 Memc_incr => 'No',
537 Memc_miss => 'No',
538 Memc_prepend => 'No',
539 Memc_replace => 'No',
540 Memc_set => 'No',
541 Memc_miss => 'Yes',
542 Memc_error => 'No',
543 Query_time => '0.000016',
544 bytes => undef,
545 exptime => undef,
546 flags => undef,
547 host => '127.0.0.1',
548 pos_in_log => 0,
549 ts => '2009-06-11 21:54:49.059144',
550 val => '',
551 },
552 ],
553 'samples/memc_tcpdump007.txt: get nonexistent key'
554);
555
556# A session with a huge get() that will not fit into a single TCP packet, but
557# the connection seems to be broken in the middle of the receive and then the
558# new client picks up and asks for something different.
559$events = make_events(
560 {
561 Query_time => '0.000003',
562 bytes => 17946,
563 cmd => 'get',
564 exptime => undef,
565 flags => 0,
566 host => '127.0.0.1',
567 key => 'my_key',
568 pos_in_log => 0,
569 res => 'INTERRUPTED',
570 ts => '2009-07-06 22:07:14.411331',
571 val => '',
572 },
573 { Query_time => '0.000001',
574 cmd => 'get',
575 key => 'my_key',
576 val => 'Some value',
577 bytes => 10,
578 exptime => undef,
579 flags => 0,
580 host => '127.0.0.1',
581 pos_in_log => 5382,
582 res => 'VALUE',
583 ts => '2009-07-06 22:07:14.411334',
584 },
585);
586is_deeply(
587 $events,
588 [
589 {
590 arg => 'get my_key',
591 fingerprint => 'get my_key',
592 key_print => 'my_key',
593 cmd => 'get',
594 key => 'my_key',
595 res => 'INTERRUPTED',
596 Memc_add => 'No',
597 Memc_append => 'No',
598 Memc_cas => 'No',
599 Memc_decr => 'No',
600 Memc_delete => 'No',
601 Memc_error => 'No',
602 Memc_get => 'Yes',
603 Memc_gets => 'No',
604 Memc_incr => 'No',
605 Memc_miss => 'No',
606 Memc_prepend => 'No',
607 Memc_replace => 'No',
608 Memc_set => 'No',
609 Memc_miss => 'No',
610 Memc_error => 'Yes',
611 Query_time => '0.000003',
612 bytes => 17946,
613 exptime => undef,
614 flags => 0,
615 host => '127.0.0.1',
616 pos_in_log => 0,
617 ts => '2009-07-06 22:07:14.411331',
618 val => '',
619 },
620 {
621 arg => 'get my_key',
622 fingerprint => 'get my_key',
623 key_print => 'my_key',
624 cmd => 'get',
625 key => 'my_key',
626 res => 'VALUE',
627 Memc_add => 'No',
628 Memc_append => 'No',
629 Memc_cas => 'No',
630 Memc_decr => 'No',
631 Memc_delete => 'No',
632 Memc_error => 'No',
633 Memc_get => 'Yes',
634 Memc_gets => 'No',
635 Memc_incr => 'No',
636 Memc_miss => 'No',
637 Memc_prepend => 'No',
638 Memc_replace => 'No',
639 Memc_set => 'No',
640 Memc_miss => 'No',
641 Memc_error => 'No',
642 Query_time => '0.000001',
643 val => 'Some value',
644 bytes => 10,
645 exptime => undef,
646 flags => 0,
647 host => '127.0.0.1',
648 pos_in_log => 5382,
649 ts => '2009-07-06 22:07:14.411334',
650 },
651 ],
652 'samples/memc_tcpdump008.txt: interrupted huge get'
653);
654
655# A session with a delete() that doesn't exist. TODO: delete takes a queue_time.
656$events = make_events(
657 {
658 Query_time => '0.000022',
659 bytes => undef,
660 cmd => 'delete',
661 exptime => undef,
662 flags => undef,
663 host => '127.0.0.1',
664 key => 'comment_1873527',
665 pos_in_log => 0,
666 res => 'NOT_FOUND',
667 ts => '2009-06-11 21:54:52.244534',
668 val => '',
669 },
670);
671is_deeply(
672 $events,
673 [
674 {
675 arg => 'delete comment_1873527',
676 fingerprint => 'delete comment_?',
677 key_print => 'comment_?',
678 cmd => 'delete',
679 key => 'comment_1873527',
680 res => 'NOT_FOUND',
681 Memc_add => 'No',
682 Memc_append => 'No',
683 Memc_cas => 'No',
684 Memc_decr => 'No',
685 Memc_delete => 'Yes',
686 Memc_error => 'No',
687 Memc_get => 'No',
688 Memc_gets => 'No',
689 Memc_incr => 'No',
690 Memc_miss => 'No',
691 Memc_prepend => 'No',
692 Memc_replace => 'No',
693 Memc_set => 'No',
694 Memc_miss => 'Yes',
695 Memc_error => 'No',
696 Query_time => '0.000022',
697 bytes => undef,
698 exptime => undef,
699 flags => undef,
700 host => '127.0.0.1',
701 pos_in_log => 0,
702 ts => '2009-06-11 21:54:52.244534',
703 val => '',
704 },
705 ],
706 'samples/memc_tcpdump009.txt: delete nonexistent key'
707);
708
709# A session with a delete() that does exist.
710$events = make_events(
711 {
712 Query_time => '0.000120',
713 bytes => undef,
714 cmd => 'delete',
715 exptime => undef,
716 flags => undef,
717 host => '127.0.0.1',
718 key => 'my_key',
719 pos_in_log => 0,
720 res => 'DELETED',
721 ts => '2009-07-09 22:00:29.066476',
722 val => '',
723 },
724);
725is_deeply(
726 $events,
727 [
728 {
729 arg => 'delete my_key',
730 fingerprint => 'delete my_key',
731 key_print => 'my_key',
732 cmd => 'delete',
733 key => 'my_key',
734 res => 'DELETED',
735 Memc_add => 'No',
736 Memc_append => 'No',
737 Memc_cas => 'No',
738 Memc_decr => 'No',
739 Memc_delete => 'Yes',
740 Memc_error => 'No',
741 Memc_get => 'No',
742 Memc_gets => 'No',
743 Memc_incr => 'No',
744 Memc_miss => 'No',
745 Memc_prepend => 'No',
746 Memc_replace => 'No',
747 Memc_set => 'No',
748 Memc_miss => 'No',
749 Memc_error => 'No',
750 Query_time => '0.000120',
751 bytes => undef,
752 exptime => undef,
753 flags => undef,
754 host => '127.0.0.1',
755 pos_in_log => 0,
756 ts => '2009-07-09 22:00:29.066476',
757 val => '',
758 },
759 ],
760 'samples/memc_tcpdump010.txt: simple delete'
761);
762
763# #############################################################################
764# Done.
765# #############################################################################
766exit;
7670
=== removed file 't/lib/MemcachedProtocolParser.t'
--- t/lib/MemcachedProtocolParser.t 2012-03-06 13:56:08 +0000
+++ t/lib/MemcachedProtocolParser.t 1970-01-01 00:00:00 +0000
@@ -1,414 +0,0 @@
1#!/usr/bin/perl
2
3BEGIN {
4 die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n"
5 unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH};
6 unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib";
7};
8
9use strict;
10use warnings FATAL => 'all';
11use English qw(-no_match_vars);
12use Test::More tests => 28;
13
14use MemcachedProtocolParser;
15use TcpdumpParser;
16use PerconaTest;
17
18my $tcpdump = new TcpdumpParser();
19my $protocol; # Create a new MemcachedProtocolParser for each test.
20
21# A session with a simple set().
22$protocol = new MemcachedProtocolParser();
23test_protocol_parser(
24 parser => $tcpdump,
25 protocol => $protocol,
26 file => 't/lib/samples/memcached/memc_tcpdump001.txt',
27 result => [
28 { ts => '2009-07-04 21:33:39.229179',
29 host => '127.0.0.1',
30 cmd => 'set',
31 key => 'my_key',
32 val => 'Some value',
33 flags => '0',
34 exptime => '0',
35 bytes => '10',
36 res => 'STORED',
37 Query_time => sprintf('%.6f', .229299 - .229179),
38 pos_in_log => 0,
39 },
40 ],
41);
42
43# A session with a simple get().
44$protocol = new MemcachedProtocolParser();
45test_protocol_parser(
46 parser => $tcpdump,
47 protocol => $protocol,
48 file => 't/lib/samples/memcached/memc_tcpdump002.txt',
49 result => [
50 { Query_time => '0.000067',
51 cmd => 'get',
52 key => 'my_key',
53 val => 'Some value',
54 bytes => 10,
55 exptime => 0,
56 flags => 0,
57 host => '127.0.0.1',
58 pos_in_log => '0',
59 res => 'VALUE',
60 ts => '2009-07-04 22:12:06.174390'
61 },
62 ],
63);
64
65# A session with a simple incr() and decr().
66$protocol = new MemcachedProtocolParser();
67test_protocol_parser(
68 parser => $tcpdump,
69 protocol => $protocol,
70 file => 't/lib/samples/memcached/memc_tcpdump003.txt',
71 result => [
72 { Query_time => '0.000073',
73 cmd => 'incr',
74 key => 'key',
75 val => '8',
76 bytes => 0,
77 exptime => 0,
78 flags => 0,
79 host => '127.0.0.1',
80 pos_in_log => '0',
81 res => '',
82 ts => '2009-07-04 22:12:06.175734',
83 },
84 { Query_time => '0.000068',
85 cmd => 'decr',
86 bytes => 0,
87 exptime => 0,
88 flags => 0,
89 host => '127.0.0.1',
90 key => 'key',
91 pos_in_log => 522,
92 res => '',
93 ts => '2009-07-04 22:12:06.176181',
94 val => '7',
95 },
96 ],
97);
98
99# A session with a simple incr() and decr(), but the value doesn't exist.
100$protocol = new MemcachedProtocolParser();
101test_protocol_parser(
102 parser => $tcpdump,
103 protocol => $protocol,
104 file => 't/lib/samples/memcached/memc_tcpdump004.txt',
105 result => [
106 { Query_time => '0.000131',
107 bytes => 0,
108 cmd => 'incr',
109 exptime => 0,
110 flags => 0,
111 host => '127.0.0.1',
112 key => 'key',
113 pos_in_log => 764,
114 res => 'NOT_FOUND',
115 ts => '2009-07-06 10:37:21.668469',
116 val => '',
117 },
118 {
119 Query_time => '0.000055',
120 bytes => 0,
121 cmd => 'decr',
122 exptime => 0,
123 flags => 0,
124 host => '127.0.0.1',
125 key => 'key',
126 pos_in_log => 1788,
127 res => 'NOT_FOUND',
128 ts => '2009-07-06 10:37:21.668851',
129 val => '',
130 },
131 ],
132);
133
134# A session with a huge set() that will not fit into a single TCP packet.
135$protocol = new MemcachedProtocolParser();
136test_protocol_parser(
137 parser => $tcpdump,
138 protocol => $protocol,
139 file => 't/lib/samples/memcached/memc_tcpdump005.txt',
140 result => [
141 { Query_time => '0.003928',
142 bytes => 17946,
143 cmd => 'set',
144 exptime => 0,
145 flags => 0,
146 host => '127.0.0.1',
147 key => 'my_key',
148 pos_in_log => 764,
149 res => 'STORED',
150 ts => '2009-07-06 22:07:14.406827',
151 val => ('lorem ipsum dolor sit amet' x 690) . ' fini!',
152 },
153 ],
154);
155
156# A session with a huge get() that will not fit into a single TCP packet.
157$protocol = new MemcachedProtocolParser();
158test_protocol_parser(
159 parser => $tcpdump,
160 protocol => $protocol,
161 file => 't/lib/samples/memcached/memc_tcpdump006.txt',
162 result => [
163 {
164 Query_time => '0.000196',
165 bytes => 17946,
166 cmd => 'get',
167 exptime => 0,
168 flags => 0,
169 host => '127.0.0.1',
170 key => 'my_key',
171 pos_in_log => 0,
172 res => 'VALUE',
173 ts => '2009-07-06 22:07:14.411331',
174 val => ('lorem ipsum dolor sit amet' x 690) . ' fini!',
175 },
176 ],
177);
178
179# A session with a get() that doesn't exist.
180$protocol = new MemcachedProtocolParser();
181test_protocol_parser(
182 parser => $tcpdump,
183 protocol => $protocol,
184 file => 't/lib/samples/memcached/memc_tcpdump007.txt',
185 result => [
186 {
187 Query_time => '0.000016',
188 bytes => 0,
189 cmd => 'get',
190 exptime => 0,
191 flags => 0,
192 host => '127.0.0.1',
193 key => 'comment_v3_482685',
194 pos_in_log => 0,
195 res => 'NOT_FOUND',
196 ts => '2009-06-11 21:54:49.059144',
197 val => '',
198 },
199 ],
200);
201
202# A session with a huge get() that will not fit into a single TCP packet, but
203# the connection seems to be broken in the middle of the receive and then the
204# new client picks up and asks for something different.
205$protocol = new MemcachedProtocolParser();
206test_protocol_parser(
207 parser => $tcpdump,
208 protocol => $protocol,
209 file => 't/lib/samples/memcached/memc_tcpdump008.txt',
210 result => [
211 {
212 Query_time => '0.000003',
213 bytes => 17946,
214 cmd => 'get',
215 exptime => 0,
216 flags => 0,
217 host => '127.0.0.1',
218 key => 'my_key',
219 pos_in_log => 0,
220 res => 'INTERRUPTED',
221 ts => '2009-07-06 22:07:14.411331',
222 val => '',
223 },
224 { Query_time => '0.000001',
225 cmd => 'get',
226 key => 'my_key',
227 val => 'Some value',
228 bytes => 10,
229 exptime => 0,
230 flags => 0,
231 host => '127.0.0.1',
232 pos_in_log => 5382,
233 res => 'VALUE',
234 ts => '2009-07-06 22:07:14.411334',
235 },
236 ],
237);
238
239# A session with a delete() that doesn't exist. TODO: delete takes a queue_time.
240$protocol = new MemcachedProtocolParser();
241test_protocol_parser(
242 parser => $tcpdump,
243 protocol => $protocol,
244 file => 't/lib/samples/memcached/memc_tcpdump009.txt',
245 result => [
246 {
247 Query_time => '0.000022',
248 bytes => 0,
249 cmd => 'delete',
250 exptime => 0,
251 flags => 0,
252 host => '127.0.0.1',
253 key => 'comment_1873527',
254 pos_in_log => 0,
255 res => 'NOT_FOUND',
256 ts => '2009-06-11 21:54:52.244534',
257 val => '',
258 },
259 ],
260);
261
262# A session with a delete() that does exist.
263$protocol = new MemcachedProtocolParser();
264test_protocol_parser(
265 parser => $tcpdump,
266 protocol => $protocol,
267 file => 't/lib/samples/memcached/memc_tcpdump010.txt',
268 result => [
269 {
270 Query_time => '0.000120',
271 bytes => 0,
272 cmd => 'delete',
273 exptime => 0,
274 flags => 0,
275 host => '127.0.0.1',
276 key => 'my_key',
277 pos_in_log => 0,
278 res => 'DELETED',
279 ts => '2009-07-09 22:00:29.066476',
280 val => '',
281 },
282 ],
283);
284
285# #############################################################################
286# Issue 537: MySQLProtocolParser and MemcachedProtocolParser do not handle
287# multiple servers.
288# #############################################################################
289$protocol = new MemcachedProtocolParser();
290test_protocol_parser(
291 parser => $tcpdump,
292 protocol => $protocol,
293 file => 't/lib/samples/memcached/memc_tcpdump011.txt',
294 result => [
295 { Query_time => '0.000067',
296 cmd => 'get',
297 key => 'my_key',
298 val => 'Some value',
299 bytes => 10,
300 exptime => 0,
301 flags => 0,
302 host => '127.0.0.8',
303 pos_in_log => '0',
304 res => 'VALUE',
305 ts => '2009-07-04 22:12:06.174390'
306 },
307 { ts => '2009-07-04 21:33:39.229179',
308 host => '127.0.0.9',
309 cmd => 'set',
310 key => 'my_key',
311 val => 'Some value',
312 flags => '0',
313 exptime => '0',
314 bytes => '10',
315 res => 'STORED',
316 Query_time => sprintf('%.6f', .229299 - .229179),
317 pos_in_log => 638,
318 },
319 ],
320);
321
322# #############################################################################
323# Issue 544: memcached parse error
324# #############################################################################
325
326# Multiple delete in one packet.
327$protocol = new MemcachedProtocolParser();
328test_protocol_parser(
329 parser => $tcpdump,
330 protocol => $protocol,
331 file => 't/lib/samples/memcached/memc_tcpdump014.txt',
332 result => [
333 { ts => '2009-10-06 10:31:56.323538',
334 Query_time => '0.000024',
335 bytes => 0,
336 cmd => 'delete',
337 exptime => 0,
338 flags => 0,
339 host => '10.0.0.5',
340 key => 'ABBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBC',
341 pos_in_log => 0,
342 res => 'NOT_FOUND',
343 val => ''
344 },
345 ],
346);
347
348# Multiple mixed commands: get delete delete
349$protocol = new MemcachedProtocolParser();
350test_protocol_parser(
351 parser => $tcpdump,
352 protocol => $protocol,
353 file => 't/lib/samples/memcached/memc_tcpdump015.txt',
354 result => [
355 { ts => '2009-10-06 10:31:56.330709',
356 Query_time => '0.000013',
357 bytes => 0,
358 cmd => 'get',
359 exptime => 0,
360 flags => 0,
361 host => '10.0.0.5',
362 key => 'ABBBBBBBBBBBBBBBBBBBBBC',
363 pos_in_log => 0,
364 res => 'NOT_FOUND',
365
366 val => ''
367 },
368 ],
369);
370
371
372# #############################################################################
373# Issue 818: mk-query-digest: error parsing memcached dump - use of
374# uninitialized value in addition
375# #############################################################################
376
377# A replace command.
378$protocol = new MemcachedProtocolParser();
379test_protocol_parser(
380 parser => $tcpdump,
381 protocol => $protocol,
382 file => 't/lib/samples/memcached/memc_tcpdump016.txt',
383 result => [
384 { ts => '2010-01-20 10:27:18.510727',
385 Query_time => '0.000030',
386 bytes => 56,
387 cmd => 'replace',
388 exptime => '43200',
389 flags => '1',
390 host => '192.168.0.3',
391 key => 'BD_Uk_cms__20100120_095702tab_containerId_410',
392 pos_in_log => 0,
393 res => 'STORED',
394 val => 'a:3:{i:0;s:6:"a:0:{}";i:1;i:1263983238;i:2;s:5:"43200";}'
395 },
396 { ts => '2010-01-20 10:27:18.510876',
397 Query_time => '0.000066',
398 bytes => '56',
399 cmd => 'get',
400 exptime => 0,
401 flags => '1',
402 host => '192.168.0.3',
403 key => 'BD_Uk_cms__20100120_095702tab_containerId_410',
404 pos_in_log => 893,
405 res => 'VALUE',
406 val => 'a:3:{i:0;s:6:"a:0:{}";i:1;i:1263983238;i:2;s:5:"43200";}'
407 }
408 ],
409);
The diff has been truncated for viewing.

Subscribers

People subscribed via source and target branches