File Coverage

blib/lib/Regexp/Log.pm

Criterion	Covered	Total	%
statement	92	92	100.0
branch	30	30	100.0
condition			n/a
subroutine	15	15	100.0
pod	5	5	100.0
total	142	142	100.0

package Regexp::Log;

use strict;
use Carp;
use vars qw( $VERSION );

$VERSION = 0.06;

sub new {
    my $class = shift;
    no strict 'refs';
    my $self = bless {
        debug       => 0,
        comments    => 0,
        anchor_line => 1,
        modifiers   => '',
        %{"${class}::DEFAULT"},
        @_
    }, $class;

    # some initialisation code
    if ( my @capture = @{ $self->{capture} } ) {
        $self->{capture} = [];
        $self->capture(@capture);
    }

    return $self;
}

sub format {
    my $self = shift;
    $self->{format} = shift if @_;
    return $self->{format};
}

sub capture {
    my $self = shift;

    # add the new tags to capture
    for (@_) {

        # special tags
        if ( $_ eq ':none' ) { $self->{capture} = [] }
        elsif ( $_ eq ':all' ) {
            $self->{capture} = [ $self->fields ];
        }

        # normal tags
        else { push @{ $self->{capture} }, $_ }
    }

    my %capture = map { ( $_, 1 ) } @{ $self->{capture} };
    $self->{capture} = [ keys %capture ] if @_;

    # compute what will be actually captured, in which order
    $self->_regexp;
    return grep { $capture{$_} } ( $self->{_regexp} =~ /\(\?\#=([-\w]+)\)/g );

}

# this internal method actually computes the correct regular expression
sub _regexp {
    my $self  = shift;
    my $class = ref $self;

    $self->{_regexp} = $self->{format};

    $self->{_regexp} =~ s/([\\|()\[\]{}^\$*+?.])/\\$1/g;
    $self->_preprocess if $self->can('_preprocess');

    # accept predefined formats
    no strict 'refs';
    $self->{format} = ${"${class}::FORMAT"}{ $self->{format} }
      if exists ${"${class}::FORMAT"}{ $self->{format} };

    my $convert = join '|', reverse sort keys %{"${class}::REGEXP"};
    $self->{_regexp} =~ s/($convert)/${"${class}::REGEXP"}{$1}/g;

    $self->_postprocess if $self->can('_postprocess');
}

sub regexp {
    my $self   = shift;
    $self->_regexp;
    my $regexp = $self->{_regexp};

    my %capture = map { ( $_, 1 ) } @{ $self->{capture} };

    # this is complicated, but handles multiple levels of imbrication
    my $pos = 0;
    while ( ( $pos = index( $regexp, "(?#=", $pos ) ) != -1 ) {
        ( pos $regexp ) = $pos;
        $regexp =~ s{\G\(\?\#=([-\w]+)\)(.*?)\(\?\#\!\1\)}
                    { exists $capture{$1} ? "((?#=$1)$2(?#!$1))"
                                          : "(?:(?#=$1)$2(?#!$1))" }ex;
        $pos += 4;    # oh my! a magic constant!
    }

    # for regexp debugging
    if ( $self->debug ) {
        $regexp =~ s/\(\?\#\!([-\w]+)\)/(?#!$1)(?{ print STDERR "$1 "})/g;
        $regexp =~ s/^/(?{ print STDERR "\n"})/;
    }

    # remove comments
    $regexp =~ s{\(\?\#[=!][^)]*\)}{}g unless $self->comments;

    # include anchors
    $regexp = qq{\^$regexp\$} if $self->anchor_line;

    # include modifiers
    $regexp = join '', '(?', $self->modifiers, ":$regexp)"
        if length $self->modifiers;

    # compute the regexp
    if ( $self->debug ) { use re 'eval'; $regexp = qr/$regexp/; }
    else { $regexp = qr/$regexp/ }

    return $regexp;
}

*regex = \®exp;

sub fields {
    my $self  = shift;
    my $class = ref $self;
    no strict 'refs';
    return map { (/\(\?\#=([-\w]+)\)/g) } values %{"${class}::REGEXP"};
}

for my $attr (qw( comments modifiers anchor_line debug )) {
    no strict 'refs';
    *$attr = sub {
        my $self = shift;
        $self->{$attr} = shift if @_;
        return $self->{$attr};
    };
}

1;

__END__