MMAgic/Log/Parser.pm

Go to the documentation of this file.

package MMAgic::Log::Parser;
#
# MMAgic/Log/Parser.pm
#
#   Parse log files.
#

use     Date::Manip;
use     File::Basename;
use     Time::Local;
use     UNIVERSAL   qw(isa);

use     MMAgic::Log;
use     MMAgic::Tie::Hash::Fuzzy;
use     MMAgic::Trace;

# Would include these from Fcntl but stuck w/Perl 5.003 on Linux 6.1:
sub SEEK_SET    { 0 }
sub SEEK_CUR    { 1 }
sub SEEK_END    { 2 }

$nameLen =    8;
$granule = 1024;
$idlesec = 7200;    # two hours

tie %month, 'MMAgic::Tie::Hash::Fuzzy';
map {
    $month{qr/^$_/i} = int($month);
    $month++;
    } qw(jan feb mar apr may jun jul aug sep oct nov dec);

###########################################################################
###########################################################################
sub new     # $class, %init
#
    {
    my  $clss = shift;
#!# my  $auto = Log->method('%', @_)->block;
    my  %init = @_;
    
    Log->error('File ', $init{path}, ' doesn\'t exist.'),
    return undef
        unless -f $init{path};
    
    Log->error('File ', $init{path}, ' isn\'t readable.'),
    return undef
        unless -r $init{path};
    
    my  $hndl = new IO::File($init{path});
    
    Log->error('Unable to open ', $init{path}, ' for reading'),
    return undef
        unless isa($hndl, 'IO::File');
    
    my ($name, $path, $suff) = fileparse($init{path}, '.[^\.]*');
    
    $name = $init{name} if $init{name};
    
    if ($suff =~ /^\.\d*$/)
        {
        # Suffix is all digits, map over filename:
        $name .=  ' ' while length($name) < $nameLen;
        $suff  =~ s/^\.0*(\d)$/$1/;
        substr($name, $nameLen - length($suff), length($suff)) = $suff;
        }
    
    if ($init{type})
        {
        $clss = __PACKAGE__ . "::$init{type}";
        eval "require $clss";

        Log->error('Unable to load class ', $clss, "\n  $@"),
        return undef
            if $@;
        }
    
    my  $self = bless
        {
        catchUp  => $init{catchUp},
        handle   => $hndl,
        name     => $name,
        pathname => $init{path},
        parsed   => [ ],
        patterns => [ ],
        queue    => [ ],
        virgin   => 1,
        }, $clss;
    
    map {
        push @{$self->{patterns}},
             isa($_, 'Regexp') ? $_ : qr($_);
        } isa($init{'grep'}, 'ARRAY') ? @{$init{'grep'}}  :
          $init{'grep'}               ? ( $init{'grep'} ) : ( );
    
#   if (isa($init{'grep'}, 'ARRAY'))
#       {
#       my  @matches = map
#           {
#           isa($_, 'Regexp') ? $_ : qr($_);
#           } @{$init{'grep'}};
#       
#       $self->{patterns} = \@matches;
#       }
#   
#   elsif ($init{'grep'})
#       {
#       $self->{patterns} = isa($init{'grep'}, 'Regexp')
#                         ? [ $init{'grep'} ]
#                         : [ qr($init{'grep'}) ];
#       }
    
    $self
    }

###########################################################################
###########################################################################
sub catchUp     {   $_[0]->{catchUp}    }
sub dead        {   $_[0]->{dead}       }
sub handle      {   $_[0]->{handle}     }
sub lastDate    {   $_[0]->{lastDate}   }
sub name        {   $_[0]->{name}       }
sub path        {   $_[0]->{pathname}   }

###########################################################################
###########################################################################
sub getparsed   # $self, ...
#
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;

    # There might be one we just parsed in getmsg():
    return shift @{$self->{parsed}}
        if @{$self->{parsed}};
    
    # Need a new one, no old ones cached:
    while (my $line = $self->{handle}->getline)
        {
        chomp $line;

        next unless $line;      # get rid of blank lines in logs
        
        my  @data = $self->parse($line, @_);
        
        $self->{lastDate} = $data[0]    # track last msg time
            if $data[0] > $self->{lastDate};
        
        next unless $data[2];   # get rid of blank messages in logs
        
        return \@data;
        }
    
    # Here we are, having hit the end of the file,
    #   is it one that hasn't seen action in a while?
    my (undef, undef, undef, undef, undef, undef, undef, undef, undef,
        $mtime) = $self->{handle}->stat;
    
    return
        unless $now - $mtime > $idlesec;

    # File hasn't seen action in a while,
    #   giving up means maybe some other file can open:
    $self->{dead} = time;
    undef $self->{handle};
    undef
    }

###########################################################################
sub getmsg  # $self, $now [, $unrec ]
# Return a single message from the stream.
#   Must parse message and collect related lines into single item.
#
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;
    my  $now  = shift;

    return undef if $self->{dead};
    
    # Look for a message previously parsed that is good timewise:
#!# Log->trace('Returning queued message...'),
    return $self->{queue}->[0]->[0] <= $now
         ? shift(@{$self->{queue}}) # found one ready, pull from queue
         : $self->{queue}->[0]->[0] # not yet, so return its time
        if @{$self->{queue}};
    
    # Nothing queued, parse a new one from the file:
    my  $msg = undef;
    
    while (my $data = $self->getparsed(@_))
        {
#!#     Log->trace('Msg:  ', join(', ', @$data));
        
        while (my $dnxt = $self->getparsed(@_))
            {
#!#         Log->trace('Ext:  ', join(', ', @$dnxt));
            # Get any extension messages ('+' flag)
            if ($dnxt->[1] eq '+')
                {
                # Append next line onto this one:
                $data->[2] .= "\n";
                $data->[2] .= $dnxt->[2];
                }
            
            else
                {
                # Try the parsed line again later:
                unshift @{$self->{parsed}}, $dnxt;
                last;   # done for now
                }
            }

        if ($self->{virgin} && ! $self->{catchUp})
            {
            # First time through, if we're not in catch-up mode
            #   for a late addition, want to skip through to
            #   find beginning of file:
            if ($data->[0] < $now)
                {
#!#             Log->trace('Skipping early one ', $data->[0], '<', $now),
                $self->{skipped} = $self->skip($now)
                    unless $self->{skipped};
                
                next;
                }
            
            # We've got a good message in our time slot,
            #   don't come through this code any more:
            undef $self->{virgin};
            }
        
#!#     Log->trace('Skipping uninteresting one'),
        next
            unless $self->matches($data->[2]);
        
        undef $self->{catchUp}
            if $self->{catchUp}
            && $data->[0] >= $now;
        
#!#     Log->trace('Queue late one:  ', scalar(localtime($data->[0]))),
        push(@{$self->{queue}}, $data),
        return $data->[0]
            if $data->[0] > $now;
        
#!#     Log->trace('returning good one');
        return $data;
        }
    }

###########################################################################
sub makeTime    # $self, $date, $sec, $min, $hour, $mday, $mon, $year
#
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;
    my  $date = shift;
    
    if (@_ > 5)
        {
        # Convert month name to number if necessary:
        my ($sec, $min, $hour, $day, $mon, $year) = @_;
        my  $res = undef;
        
        if (int($mon))  {   $mon--;                 }
        else            {   $mon = $month{$mon};    }
        
        $year -= 1900 if $year > 1900;
        
        eval
            {
            $res = timelocal($sec, $min, $hour, $day, $mon, $year);
            };
        
        Log->warning("Unable to make time $date properly\n  $@"),
        undef $res
            if $@;
        
        return $res if int($res)
        }
    
    Log->warning('Must parse ', $self->name,
               "\n  date ", $date, ' ', join(', ', @_),
               "\n  with Date::Manip");
    $date = ParseDateString($date);
    $date && UnixDate($date, '%s')
    }

###########################################################################
sub matches # $self, $msg
#
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;
    my  $msg  = shift;
    
#!# Log->trace('Nothing specified'),
    return 1    # always matches when nothing specified
        unless @{$self->{patterns}};
    
    map {
#!#     Log->trace('- ', $_);
#!#     Log->trace('  matched!'),
        return 1
            if $msg =~ $_;
        } @{$self->{patterns}};
    
    undef
    }

###########################################################################
sub parse   # $self, $line [, $unrec ]
# Parse a log file line.
#   This version does the format generated by MMAgic::Log.
#   Overload to define other parsing strategies.
#
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;
    my  $line = shift;
    my ($date, $flag, $msg) = (undef, '?', $line);
    
    if ($line =~ /^\s*([^\[\]]*) \[([^\[\]])\] (.*)$/)
        {
        # Timestamp, then flag:
        $date = $1;
        $flag = $2;
        $msg  = $3;
        }
    
    elsif ($line =~ /^\s*\[([^\[\]])\] ([0-9\/: ]{8,19}) (.*)$/)
        {
        # Flag, then timestamp:
        $date = $2;
        $flag = $1;
        $msg  = $3;
        }
    
    elsif (my $unrec = shift())
        {
        $unrec->warning('Unrecognizable ', $self->name, " line:\n  ", $line);
        }
    
    if ($date)
        {
        if ($date =~ /^\s*(\d{1,2}):(\d{1,2}):(\d{1,2})\s*$/)
            {
            # Time only:
            my  @now = localtime(time);
            
            ($now[0], $now[1], $now[2]) = ($3, $2, $1);
            $date = $self->makeTime($date, @now);
            }
        
        elsif ($date =~ m|(\d{2,4})/(\d{1,2})/(\d{1,2}) (\d{1,2}):(\d{1,2}):(\d{1,2})|)
            {
            # Date and time:
            $date = $self->makeTime($date, $6, $5, $4, $3, $2, $1);
            }
        
        else
            {
            # Oh, well, better to go for it slowly than not at all:
            $date = $self->makeTime($date);
            }
        }
    
#   Log->warning('No date from ', $self->name),
    $date = $self->lastDate
        unless int($date);
    
    ( $date, $flag, $msg )
    }

###########################################################################
sub skip    # $self, $now
# Skip ahead through file to find our time slot.
#   Attempt to shorten long waits loading Apache error logs.
#
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;
    my  $now  = shift;
    my  $here = $self->{handle}->tell;
    
    return undef
        if $here < 0;  # error in tell()
    
    return undef
        unless $self->{handle}->seek(0, SEEK_END);
    
    my  $end  = $self->{handle}->tell;
    
    $self->{handle}->seek($here, SEEK_SET),
    return undef
        if $end < 0;    # error in tell()

    my  $low  = $here;
    my  $high = $end;
    
  BSearch:  # binary search for block where we should start parsing
    while ($high - $low > $granule)
        {
        # There's some potential payoff to skipping ahead:
        my  $mid  = ($low + $high) / 2;
#!#     Log->trace('High:  ', $high);
#!#     Log->trace('Mid:   ', $mid);
#!#     Log->trace('Low:   ', $low);
        
        last unless $self->{handle}->seek($mid, SEEK_SET);
        
        # Trash the first partial line:
        my  $line = $self->{handle}->getline;
        
        # Memorize this point in the file in case it's good:
        last if ($mid = $self->{handle}->tell) < 0;
        
        while ($line = $self->{handle}->getline)
            {
            my  @data = $self->parse($line);
            
            if ($data[1] eq '+')
                {
                # Left-over from previous message block,
                #   trash this entire line, memorize new point:
                last BSearch if ($mid = $self->{handle}->tell) < 0;
                }

            elsif ($data[0] < $now)
                {
                # This one's too far in the past,
                #   so it's safe to move up this far!:
                $low = $mid;
                last
                }
            
            else
                {
                # Still too far in the future,
                #   or dead on but that still means go back:
                $high = $mid;
                last
                }
            }
        }
    
    # Payoff!  Here's where we get to jump ahead
    #   to the last known good point:
    $self->{handle}->seek($low, SEEK_SET);
    # (doesn't matter if $low is what used to be $here,
    #  we've been moving the file pointer and have to
    #  reset it to $here if there is no $low anyway)

    Log->info ('Skipped ', $low - $here, ' bytes in ', $self->{name})
        unless $low == $here;

#!# Log->trace('Skipped nowhere') if     $low == $here;
    1
    }

1