26
26
use warnings FATAL => 'all';
27
27
use English qw(-no_match_vars);
28
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
28
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
31
31
$Data::Dumper::Indent = 1;
172
172
# the header in it. But, we only do this if we aren't in the middle of an
173
173
# ongoing event, whose first line was pending.
174
174
if ( !$was_pending && (!defined $line || $line !~ m/$log_line_regex/o) ) {
175
MKDEBUG && _d('Skipping lines until I find a header');
175
PTDEBUG && _d('Skipping lines until I find a header');
176
176
my $found_header;
189
MKDEBUG && _d('Line was not a header, will fetch another');
189
PTDEBUG && _d('Line was not a header, will fetch another');
192
MKDEBUG && _d('Found a header line, now at pos_in_line', $pos_in_log);
192
PTDEBUG && _d('Found a header line, now at pos_in_line', $pos_in_log);
195
195
# We need to keep the line that begins the event we're parsing.
215
215
# There's something in progress, so we abort the loop and let it be
216
216
# handled specially.
217
217
if ( @arg_lines ) {
218
MKDEBUG && _d('Found a non-LOG line, exiting loop');
218
PTDEBUG && _d('Found a non-LOG line, exiting loop');
227
227
# Handle ERROR and STATEMENT lines...
228
228
if ( my ($e) = $line =~ m/ERROR:\s+(\S.*)\Z/s ) {
229
229
push @properties, 'Error_msg', $e;
230
MKDEBUG && _d('Found an error msg, saving and continuing');
230
PTDEBUG && _d('Found an error msg, saving and continuing');
231
231
($new_pos, $line) = $self->get_line();
235
235
elsif ( my ($s) = $line =~ m/STATEMENT:\s+(\S.*)\Z/s ) {
236
236
push @properties, 'arg', $s, 'cmd', 'Query';
237
MKDEBUG && _d('Found a statement, finishing up event');
237
PTDEBUG && _d('Found a statement, finishing up event');
243
MKDEBUG && _d("I don't know what to do with this line");
243
PTDEBUG && _d("I don't know what to do with this line");
276
276
# We get the next line to process and skip the rest of the loop.
277
MKDEBUG && _d('Skipping this line because it matches skip-pattern');
277
PTDEBUG && _d('Skipping this line because it matches skip-pattern');
278
278
($new_pos, $line) = $self->get_line();
310
310
my ( $sev, $label, $rest )
311
311
= $line =~ m/$log_line_regex(.+?):\s+(.*)\Z/so
313
MKDEBUG && _d('Line is case 1 or case 3');
313
PTDEBUG && _d('Line is case 1 or case 3');
315
315
# This is either a case 1 or case 3. If there's previously gathered
316
316
# data in @arg_lines, it doesn't matter which -- we have to create an
317
317
# event (a Query event), and we're $done. This is case 0xdeadbeef.
318
318
if ( @arg_lines ) {
320
MKDEBUG && _d('There are saved @arg_lines, we are done');
320
PTDEBUG && _d('There are saved @arg_lines, we are done');
322
322
# We shouldn't modify @properties based on $line, because $line
323
323
# doesn't have anything to do with the stuff in @properties, which
330
330
if ( $label eq 'duration' && $rest =~ m/[0-9.]+\s+\S+\Z/ ) {
331
331
if ( $got_duration ) {
332
332
# Just discard the line.
333
MKDEBUG && _d('Discarding line, duration already found');
333
PTDEBUG && _d('Discarding line, duration already found');
336
336
push @properties, 'Query_time', $self->duration_to_secs($rest);
337
MKDEBUG && _d("Line's duration is for previous event:", $rest);
337
PTDEBUG && _d("Line's duration is for previous event:", $rest);
341
341
# We'll come back to this line later.
342
342
$self->pending($new_pos, $line);
343
MKDEBUG && _d('Deferred line');
343
PTDEBUG && _d('Deferred line');
347
347
# Here we test for case 1, lines that can start a multi-line event.
348
348
elsif ( $label =~ m/\A(?:duration|statement|query)\Z/ ) {
349
MKDEBUG && _d('Case 1: start a multi-line event');
349
PTDEBUG && _d('Case 1: start a multi-line event');
351
351
# If it's a duration, then there might be a statement later on the
352
352
# same line and the duration applies to that.
372
372
# pos_in_log. See t/samples/pg-log-002.txt for an example.
373
373
$first_line = undef;
374
374
($pos_in_log, $line) = $self->get_line();
375
MKDEBUG && _d('Line applies to event we never saw, discarding');
375
PTDEBUG && _d('Line applies to event we never saw, discarding');
380
380
# This isn't a duration line, it's a statement or query. Put it
381
381
# onto @arg_lines for later and keep going.
382
382
push @arg_lines, $rest;
383
MKDEBUG && _d('Putting onto @arg_lines');
383
PTDEBUG && _d('Putting onto @arg_lines');
389
389
# such, then we just create an event without the overhead of deferring.
392
MKDEBUG && _d('Line is case 3, event is done');
392
PTDEBUG && _d('Line is case 3, event is done');
394
394
# Again, if there's previously gathered data in @arg_lines, we have
395
395
# to defer the current line (not touching @properties) and revisit it.
396
396
if ( @arg_lines ) {
397
397
$self->pending($new_pos, $line);
398
MKDEBUG && _d('There was @arg_lines, putting line to pending');
398
PTDEBUG && _d('There was @arg_lines, putting line to pending');
401
401
# Otherwise we can parse the line and put it into @properties.
403
MKDEBUG && _d('No need to defer, process event from this line now');
403
PTDEBUG && _d('No need to defer, process event from this line now');
404
404
push @properties, 'cmd', 'Admin', 'arg', $label;
406
406
# For some kinds of log lines, we can grab extra meta-data out of
433
433
# If we're at the end of the file, we finish and tell the caller we're done.
434
434
if ( !defined $line ) {
435
MKDEBUG && _d('Line not defined, at EOF; calling oktorun(0) if exists');
435
PTDEBUG && _d('Line not defined, at EOF; calling oktorun(0) if exists');
436
436
$args{oktorun}->(0) if $args{oktorun};
437
437
if ( !@arg_lines ) {
438
MKDEBUG && _d('No saved @arg_lines either, we are all done');
438
PTDEBUG && _d('No saved @arg_lines either, we are all done');
443
443
# If we got kicked out of the while loop because of a non-LOG line, we handle
444
444
# that line here.
445
445
if ( $line_type && $line_type ne 'LOG' ) {
446
MKDEBUG && _d('Line is not a LOG line');
446
PTDEBUG && _d('Line is not a LOG line');
448
448
# ERROR lines come in a few flavors. See t/samples/pg-log-006.txt,
449
449
# t/samples/pg-syslog-002.txt, and t/samples/pg-syslog-007.txt for some
455
455
# @arg_lines, then the ERROR actually starts a new event. If the ERROR is
456
456
# followed by another LOG event, then the ERROR also starts a new event.
457
457
if ( $line_type eq 'ERROR' ) {
458
MKDEBUG && _d('Line is ERROR');
458
PTDEBUG && _d('Line is ERROR');
460
460
# If there's already a statement in processing, then put aside the
461
461
# current line, and peek ahead.
462
462
if ( @arg_lines ) {
463
MKDEBUG && _d('There is @arg_lines, will peek ahead one line');
463
PTDEBUG && _d('There is @arg_lines, will peek ahead one line');
464
464
my ( $temp_pos, $temp_line ) = $self->get_line();
465
465
my ( $type, $msg );
471
471
# Looks like the whole thing is pertaining to the current event
472
472
# in progress. Add the error message to the event.
473
MKDEBUG && _d('Error/statement line pertain to current event');
473
PTDEBUG && _d('Error/statement line pertain to current event');
474
474
push @properties, 'Error_msg', $line =~ m/ERROR:\s*(\S.*)\Z/s;
475
475
if ( $type ne 'STATEMENT' ) {
476
MKDEBUG && _d('Must save peeked line, it is a', $type);
476
PTDEBUG && _d('Must save peeked line, it is a', $type);
477
477
$self->pending($temp_pos, $temp_line);
480
480
elsif ( defined $temp_line && defined $type ) {
481
481
# Looks like the current and next line are about a new event.
482
482
# Put them into pending.
483
MKDEBUG && _d('Error/statement line are a new event');
483
PTDEBUG && _d('Error/statement line are a new event');
484
484
$self->pending($new_pos, $line);
485
485
$self->pending($temp_pos, $temp_line);
488
MKDEBUG && _d("Unknown line", $line);
488
PTDEBUG && _d("Unknown line", $line);
493
MKDEBUG && _d("Unknown line", $line);
493
PTDEBUG && _d("Unknown line", $line);
500
500
# that signals the event was done. In either case we return an event. This
501
501
# should be the only 'return' statement in this block of code.
502
502
if ( $done || @arg_lines ) {
503
MKDEBUG && _d('Making event');
503
PTDEBUG && _d('Making event');
505
505
# Finish building the event.
506
506
push @properties, 'pos_in_log', $pos_in_log;
508
508
# Statement/query lines will be in @arg_lines.
509
509
if ( @arg_lines ) {
510
MKDEBUG && _d('Assembling @arg_lines: ', scalar @arg_lines);
510
PTDEBUG && _d('Assembling @arg_lines: ', scalar @arg_lines);
511
511
push @properties, 'arg', join('', @arg_lines), 'cmd', 'Query';
514
514
if ( $first_line ) {
515
515
# Handle some meta-data: a timestamp, with optional milliseconds.
516
516
if ( my ($ts) = $first_line =~ m/([0-9-]{10} [0-9:.]{8,12})/ ) {
517
MKDEBUG && _d('Getting timestamp', $ts);
517
PTDEBUG && _d('Getting timestamp', $ts);
518
518
push @properties, 'ts', $ts;
521
521
# Find meta-data embedded in the log line prefix, in name=value format.
522
522
if ( my ($meta) = $first_line =~ m/(.*?)[A-Z]{3,}: / ) {
523
MKDEBUG && _d('Found a meta-data chunk:', $meta);
523
PTDEBUG && _d('Found a meta-data chunk:', $meta);
524
524
push @properties, $self->get_meta($meta);
528
528
# Dump info about what we've found, but don't dump $event; want to see
529
529
# full dump of all properties, and after it's been cast into a hash,
530
530
# duplicated keys will be gone.
531
MKDEBUG && _d('Properties of event:', Dumper(\@properties));
531
PTDEBUG && _d('Properties of event:', Dumper(\@properties));
532
532
my $event = { @properties };
533
533
$event->{bytes} = length($event->{arg} || '');
550
550
push @properties, $prop, $val;
553
MKDEBUG && _d('Bad meta key', $set);
553
PTDEBUG && _d('Bad meta key', $set);
557
MKDEBUG && _d("Can't figure out meta from", $set);
557
PTDEBUG && _d("Can't figure out meta from", $set);
560
560
return @properties;
568
568
my ( $self ) = @_;
569
569
my ($pos, $line, $was_pending) = $self->pending;
570
570
if ( ! defined $line ) {
571
MKDEBUG && _d('Got nothing from pending, trying the $fh');
571
PTDEBUG && _d('Got nothing from pending, trying the $fh');
572
572
my ( $next_event, $tell) = @{$self}{qw(next_event tell)};
574
574
$pos = $tell->();
575
575
$line = $next_event->();
577
if ( MKDEBUG && $EVAL_ERROR ) {
577
if ( PTDEBUG && $EVAL_ERROR ) {
582
MKDEBUG && _d('Got pos/line:', $pos, $line);
582
PTDEBUG && _d('Got pos/line:', $pos, $line);
583
583
return ($pos, $line);
590
590
my ( $self, $val, $pos_in_log ) = @_;
592
MKDEBUG && _d('In sub pending, val:', $val);
592
PTDEBUG && _d('In sub pending, val:', $val);
594
594
push @{$self->{pending}}, [$val, $pos_in_log];
597
597
($val, $pos_in_log) = @{ shift @{$self->{pending}} };
598
598
$was_pending = 1;
600
MKDEBUG && _d('Return from pending:', $val, $pos_in_log);
600
PTDEBUG && _d('Return from pending:', $val, $pos_in_log);
601
601
return ($val, $pos_in_log, $was_pending);
613
613
# then they'll keep reading from old filehandles. The sanity check is based
614
614
# on the memory address of the closure!
615
615
if ( ($self->{sanity} || '') ne "$args{next_event}" ){
616
MKDEBUG && _d("Clearing and recreating internal state");
616
PTDEBUG && _d("Clearing and recreating internal state");
617
617
eval { require SysLogParser; }; # Required for tests to work.
618
618
my $sl = new SysLogParser();
647
647
sub duration_to_secs {
648
648
my ( $self, $str ) = @_;
649
MKDEBUG && _d('Duration:', $str);
649
PTDEBUG && _d('Duration:', $str);
650
650
my ( $num, $suf ) = split(/\s+/, $str);
651
651
my $factor = $suf eq 'ms' ? 1000
652
652
: $suf eq 'sec' ? 1
added
removed
lib/PgLogParser.pm
