File Coverage

blib/lib/Regexp/Log/DateRange.pm

Criterion	Covered	Total	%
statement	88	91	96.7
branch	45	54	83.3
condition	6	6	100.0
subroutine	7	7	100.0
pod	0	5	0.0
total	146	163	89.5

# $Id: DateRange.pm,v 1.2 2005/04/19 15:33:02 dk Exp $

package Regexp::Log::DateRange;
use strict;
use vars qw($VERSION %templates);

$VERSION = '0.02';

%templates = (
	syslog => [
		[ '\\s+', 1, 12, [ qw(. jan feb mar apr may jun jul aug sep oct nov dec)]],
		[ '\\s+', 1, 31, undef, '0?'],
		[ '\\:', 0, 23, undef, '0?' ],
		[ '\\:', 0, 59, undef, '0?' ],
	],
);

sub new
{
	my ( $class, $template, $date1, $date2) = @_;

	unless ( ref($template)) {
		die "Template '$template' doesn't exist\n"
			unless $templates{$template};
		$template = $templates{$template};
	}

	# some sanity checks
	my $n = @$template;
	die "template is empty\n" unless $n;
	die "date [@$date1] is not valid\n" unless $n == @$date1;
	die "date [@$date2] is not valid\n" unless $n == @$date2;

	for ( my $i = 0; $i < $n; $i++) {
		next if $date1->[$i] == $date2->[$i];
		last if $date1->[$i] < $date2->[$i];
		( $date2, $date1) = ( $date1, $date2);
		last;
	}

	# build 'alignment' vectors; for example, for the right range,
	# 2499 would give 0111, for the left, 1150 would give 0001
	my ( @w1, @w2);
	my ( $last1, $last2) = ( 1, 1);
	for ( my $i = $#$date1; $i > 0; $i--) {
		$w1[$i-1] = $last1 & (( $date1->[$i] == $template->[$i]->[1] ) ? 1 : 0);
		$w2[$i-1] = $last2 & (( $date2->[$i] == $template->[$i]->[2] ) ? 1 : 0);
		$last1 = $w1[$i-1];
		$last2 = $w2[$i-1];
	}
	my $tree = range2tree( $template, $date1, $date2, \@w1, \@w2, 0);
	return tree2re( $template, $tree, 0);
}

# 1,2,3 => (?:1|2|3)
sub re_group
{
	if ( 0 == @_) {
		return '';
	} elsif ( 1 == @_) {
		return $_[0];
	} else {
		return '(?:'.join('|', @_).')';
	}
}

# 8 .. 13 => (?:0?8|9)|1[0123]
sub match_range
{
	my ( $from, $to, $digit_prefix) = @_;

	my @tens;
	for my $x ( $from .. $to) {
		my $ten = int( $x / 10);
		unless ( defined $tens[$ten]) {
			my $mod = int( $x % 10);
			$tens[$ten] = [ $mod, $mod];
		} else {
			$tens[$ten]->[1]++;
		}
	}

	my @q;
	my $last_range = '';
	my @branges;
	for ( my $i = 0; $i < @tens; $i++) {
		next unless defined $tens[$i];
		my $range = ( $tens[$i]->[0] == $tens[$i]->[1] ) ?
			$tens[$i]->[0] :
			"[$tens[$i]->[0]-$tens[$i]->[1]]";
		if ( $i) {
			if ( $range eq $last_range) {
				push @branges, $i;
				$q[-1] = "[$branges[0]-$branges[-1]]$range";
			} else {
				$last_range = $range;
				push @q, "$i$range";
				@branges = ($i);
			}
		} else {
			push @q, "$digit_prefix$range";
		}
	}


	my $ret = re_group(@q);
	$ret =~ s/\[0-9\]/\\d/g;
	return $ret;
}

# Convert date range into a max-3-branch tree, where each branch is an alternative
# expansion rule, and is either a range or a value leaf; the value leaves can
# point deeper. For example, if matching date range 1 Apr - 3 June, the corresponding
# structure would be something like
#
#   range (Apr-May)
#   value (June,
#         range(1-3)
#   )
#
sub range2tree
{
	my ( $template, $d1, $d2, $w1, $w2, $depth) = @_;

	my ( $i, $left, $center, $right);
	my ( $r1, $r2) = ( $d1-> [$depth], $d2-> [$depth]);

#	print +('  ' x $depth), "$depth: $r1 $r2\n";

	if (
		( $w1->[$depth] and $w2->[$depth])
		or $depth >= $#$d1
	) {
		$center = {
			range => [ $r1 , $r2 ],
		};
#		print +('  ' x $depth), "T\n";
	} elsif ( $r1 < $r2) {
		my ( @d1, @d2);
		# if, say, in '123' vs '145', '2' < '4' where depth = 1,
		# then d1 = 129 and d2 = 140
		for ( $i = 0; $i <= $depth; $i++) {
			$d1[$i] = $d1->[$i];
			$d2[$i] = $d2->[$i];
		}
		for ( $i = $depth + 1; $i < @$d1; $i++) {
			$d1[$i] = $template-> [$i]->[2];
			$d2[$i] = $template-> [$i]->[1];
		}
		if ( $w1->[$depth]) {
			$r1--;
#			print +('  ' x $depth), "LT\n";
		} else {
#			print +('  ' x $depth), "$depth L > @$d1 : @d1 [@$w1]\n";
			$left = {
				next  => range2tree( $template, $d1, \@d1, $w1, [(1) x @d1], $depth + 1),
				value => $r1,
			};
#			print +('  ' x $depth), "$depth L <\n";
		}

		if ( $w2->[$depth]) {
#			print +('  ' x $depth), "RT\n";
			$r2++;
		} else {
#			print +('  ' x $depth), "$depth R > @d2 : @$d2 [@$w2]\n";
			$right = {
				next  => range2tree( $template, \@d2, $d2, [(1) x @d2], $w2, $depth + 1),
				value => $r2,
			};
#			print +('  ' x $depth), "$depth R <\n";
		}
		if ( $r1 + 1 < $r2) {
			$center = {
				range  => [ $r1 + 1 , $r2 - 1 ],
			};
#			print +('  ' x $depth), "$depth CT [ ", $r1+1, '  .. ', $r2-1, " ]\n";
		}
	} else {
		$center = {
			next  => range2tree( $template, $d1, $d2, $w1, $w2, $depth + 1),
			value => $r1,
		}
	}

	return [
		$left ? $left : (),
		$center ? $center : (),
		$right ? $right : ()
	];
}

# converts a tree into a regexp
sub tree2re
{
	my ( $template, $tree, $depth) = @_;
	my @q;
	my $t = $template-> [$depth];
	for my $hash ( @$tree) {
		if ( exists $hash-> {value}) {
			my $v = $t->[3] ?
				$t->[3]->[$hash->{value}] :
				match_range( $hash->{value}, $hash->{value}, $t->[4]);
			push @q, $v .
				$t->[0] .
				tree2re( $template, $hash-> {next}, $depth + 1);
		} else {
			my $r = $t->[3] ?
				re_group( map { $t->[3]->[$_] }
					$hash-> {range}-> [0] .. $hash-> {range}-> [1] ) :
				match_range( @{$hash-> {range}}, $t->[4]);
			push @q, $r . $t->[0];
		}
	}

	return re_group(@q);
}

1;

__END__