File Coverage

blib/lib/Apache/Log/Parser.pm

Criterion	Covered	Total	%
statement	156	163	95.7
branch	77	88	87.5
condition	17	33	51.5
subroutine	15	16	93.7
pod	0	8	0.0
total	265	308	86.0

# -*- coding: utf-8 -*-

package Apache::Log::Parser;

use strict;
use 5.008001;
our $VERSION = '0.02';

use Carp;
use List::Util qw( reduce );

our @FAST_COMMON_FIELDS = qw( rhost logname user datetime date time timezone request method path proto status bytes );
our @FAST_COMBINED_FIELDS = qw( referer agent );
our @FAST_DEBUG_FIELDS = qw( referer agent duration );

my $COMMON = [" ", [qw(rhost logname user datetime request status bytes)], undef];
my $COMBINED = [" ", [qw(rhost logname user datetime request status bytes referer agent)], sub{my $x=shift; defined($x->{agent}) and defined($x->{referer})}];
my $DEBUG = [" ", [qw(rhost logname user datetime request status bytes referer agent duration)], sub{my $x=shift; defined($x->{agent}) and defined($x->{referer}) and defined($x->{duration}) and $x->{duration} =~ m!^\d+!o}];
my $VHOST_COMMON = [" ", [qw( vhost rhost logname user datetime request status bytes )], undef];

my $STRICT_DEFAULT_FORMATS = [$DEBUG, $COMBINED, $COMMON, $VHOST_COMMON];

our @REQUIRED_FIELDS = qw( rhost logname user datetime request status bytes );
our @FIELDS_ALWAYS_RETURNED = qw( host logname user datetime date time timezone request method path proto status bytes );

sub new {
    my $class = shift;
    my $self = bless {}, $class;

    my %args = @_;
    croak "only one option from 'strict' or 'fast' required." unless ($args{strict} xor $args{fast});

    $self->{verbose} = exists($args{verbose}) ? $args{verbose} : 0;

    if ($args{strict}) {
        my @formats = (ref($args{strict}) ? @{$args{strict}} : ());
        if (scalar(@formats) > 0) {
            for (my $i = 0; $i < scalar(@formats); $i++) {
                if ($formats[$i] eq 'common') {
                    $formats[$i] = $COMMON;
                }
                elsif ($formats[$i] eq 'combined') {
                    $formats[$i] = $COMBINED;
                }
                elsif ($formats[$i] eq 'debug') {
                    $formats[$i] = $DEBUG;
                }
                elsif ($formats[$i] eq 'vhost_common') {
                    $formats[$i] = $VHOST_COMMON;
                }
                else {
                    unless (length($formats[$i]->[0]) > 0 and
                                scalar(reduce{$a += scalar(grep{$_ eq $b}@REQUIRED_FIELDS)} 0, @{$formats[$i]->[1]}) == scalar(@REQUIRED_FIELDS)) {
                        croak "specified fields not enough";
                    }
                }
            }
            $self->{try_maps} = \@formats;
        }
        else {
            $self->{try_maps} = $STRICT_DEFAULT_FORMATS;
        }
        $self->{strict} = 1;
    }
    else {
        $self->{strict} = 0;
        if (ref($args{fast}) and scalar(@{$args{fast}}) > 0) {
            my @args = @{$args{fast}};
            my @fields = ();
            foreach my $arg (@args) {
                if ($arg eq 'common') {
                    push @fields, [0, []];
                }
                elsif ($arg eq 'combined') {
                    push @fields, [scalar(@FAST_COMBINED_FIELDS), \@FAST_COMBINED_FIELDS];
                }
                elsif ($arg eq 'debug') {
                    push @fields, [scalar(@FAST_DEBUG_FIELDS), \@FAST_DEBUG_FIELDS];
                }
                elsif (ref($arg)) {
                    my @matchers = @{$arg};
                    push @fields, [scalar(@matchers), \@matchers];
                }
                else {
                    croak "unknow definition for fast parse";
                }
            }
            $self->{field_lists} = \@fields;
        }
        else {
            $self->{field_lists} = [
                [scalar(@FAST_COMBINED_FIELDS), \@FAST_COMBINED_FIELDS],
                [0, []]
            ];
        }
        my $part = q{\s*(?:"([^"]*)"|([^\s]+))?};
        my $common = q{([^\s]*)\s+([^\s]*)\s+([^\s]*)\s+\[(([^: ]+):([^ ]+) ([-+0-9]+))\]\s+"(([^\s]+) ([^\s]+)( ([^\s"]*))?)"\s+([^\s]*)\s+([^\s]*)};
        my $common_parts = 14;
        my $max_match_parts = reduce {$a > $b ? $a : $b} 0, map {$_->[0]} @{$self->{field_lists}};
        my $regex = $common . ($part x $max_match_parts);
        $self->{fastpattern} = qr/\A$regex/;
    }
    return $self;
}

# our @FAST_COMMON_FIELDS = qw( rhost logname user datetime date time timezone request method path proto status bytes );
sub parse_fast {
    my ($self, $line) = @_;
    chomp $line;
    my $pairs = {};
    my $dummy;
    my @values;
    ($pairs->{rhost}, $pairs->{logname}, $pairs->{user}, $pairs->{datetime},
     $pairs->{date}, $pairs->{time}, $pairs->{timezone}, $pairs->{request},
     $pairs->{method}, $pairs->{path}, $dummy, $pairs->{proto}, $pairs->{status},
     $pairs->{bytes}, @values) = ($line =~ $self->{fastpattern});

    unless (defined($pairs->{status}) and $pairs->{status} ne '' and
                defined($pairs->{request}) and $pairs->{request} ne '' and
                    defined($pairs->{datetime}) and $pairs->{datetime} ne '') {
        carp "unknown format: $line" if $self->{verbose};
        return undef;
    }

    foreach my $ref (@{$self->{field_lists}}) {
        my %result = (%{$pairs}); # copy not to break $pairs while trying to parse
        for (my $i = $ref->[0] - 1; $i >= 0; $i--) {
            my $x = $i * 2;
            my $v = defined($values[$x]) ? $values[$x] : $values[$x + 1];
            last if not defined $v;
            $result{$ref->[1]->[$i]} = $v;
        }
        return \%result if scalar(keys %result) >= $ref->[0] + 13;
    }
    carp "unknown format: $line" if $self->{verbose};
    return undef;
}

sub dequote {
    my $str = shift;
    return $str unless substr($str, 0, 1) eq '"';
    my $body = substr($str, 1, length($str) - 2);
    $body =~ s/\\"/"/g;
    $body;
}

sub has_unquoted_tail_doublequote {
    my $part = shift;
    return 0 if substr($part, -1, 1) ne '"';
    return 1 if substr($part, -2, 1) ne '\\';

    my $reversed_body = substr(reverse($part), 1);
    my $backslash_count = 0;
    foreach my $c (split(//, $reversed_body)) { $c eq '\\' and $backslash_count += 1 or last; }
    not ($backslash_count % 2);
}

sub separate_log_items {
    my ($sep, $buf) = @_;
    my $continuing = 0;
    my $flag_in_quoted = 1;
    my $flag_in_bracket = 2;
    my @items = ();
    my @item_parts_in_quote = ();
    my @item_parts_in_brackets = ();

    foreach my $part (split($sep, $buf)) {
        unless ($continuing) {
            if (substr($part, 0, 1) eq '"') {
                if (has_unquoted_tail_doublequote($part)) {
                    push @items, dequote($part);
                }
                else {
                    $continuing = $flag_in_quoted;
                    push @item_parts_in_quote, $part;
                }
            } elsif (substr($part, 0, 1) eq '[') {
                if (substr($part, -1, 1) eq ']') {
                    push @items, substr($part, 1, length($part) - 2);
                }
                else {
                    $continuing = $flag_in_bracket;
                    push @item_parts_in_brackets, $part;
                }
            } else {
                push @items, $part;
            }
            next
        }

        if ($continuing == $flag_in_quoted) {
            push @item_parts_in_quote, $part;
            next unless has_unquoted_tail_doublequote($part);

            push @items, dequote(join(' ', @item_parts_in_quote));
            @item_parts_in_quote = ();
            $continuing = 0;
        }
        elsif ($continuing == $flag_in_bracket) {
            push @item_parts_in_brackets, $part;
            next if substr($part, -1 , 1) ne ']';

            my $s = join(' ', @item_parts_in_brackets);
            push @items, substr($s, 1, length($s) - 2);
            @item_parts_in_brackets = ();
            $continuing = 0;
        } else {
            croak "invalid status about continuing: '$continuing'.";
        }
    }
    return @items;
}

sub set_strict_mode {
    my $self = shift;
    $self->{strict} = shift || 0;
}

sub parse_strict {
    my ($self, $line) = @_;
    chomp $line;
    foreach my $rule (@{$self->{try_maps}}) {
        my @values = separate_log_items($rule->[0], $line);
        next if scalar(@values) < 2;

        my $pairs = {};
        my $fnum = 0;
        foreach my $f (@{$rule->[1]}) {
            $pairs->{$f} = $values[$fnum];
            $fnum += 1;
        }
        next unless reduce { $a and defined($pairs->{$b}) } 1, qw( bytes status request datetime user logname rhost );

        my $req;
        ($pairs->{date}, $pairs->{time}, $pairs->{timezone}) = ($pairs->{datetime} =~ m!^([^: ]+):([^ ]+)\s([-+0-9]+)$!);
        if ($pairs->{request} =~ m!^(.*) (HTTP/\d\.\d)$!) {
            $pairs->{proto} = $2;
            $req = $1;
        }
        else {
            $pairs->{proto} = undef;
            $req = $pairs->{request};
        }
        ($pairs->{method}, $pairs->{path}) = split(/\s+/, $req, 2);
        next unless reduce { $a and defined($pairs->{$b}) } 1, qw( path time date );

        next if defined($rule->[2]) and not $rule->[2]->($pairs);

        return $pairs;
    }
    carp "unknown format: $line" if $self->{verbose};
    return undef;
}

sub parse {
    my ($self, $line) = @_;
    if ($self->{strict}) {
        return $self->parse_strict($line);
    }
    $self->parse_fast($line);
}

1;

__END__