File Coverage

blib/lib/Grep/Query/Parser.pm

Criterion	Covered	Total	%
statement	114	120	95.0
branch	53	66	80.3
condition	11	16	68.7
subroutine	19	20	95.0
pod	0	1	0.0
total	197	223	88.3

package Grep::Query::Parser;

use strict;
use warnings;

our $VERSION = '1.011';
$VERSION = eval $VERSION;

use Carp;
our @CARP_NOT = qw(Grep::Query);

use Grep::Query::Parser::QOPS;
use Parse::RecDescent;
use IO::Scalar;
use Scalar::Util qw(blessed reftype looks_like_number);
use Data::DPath qw(dpath);

my $PARSER;

sub parsequery
{
	my $query = shift;

	# we keep the actual parser as a singleton in case it's used multiple times
	#
	if (!$PARSER)
	{
		local $/ = undef;
		my $grammar = ;
		local $Parse::RecDescent::skip = qr#(?ms:\s+|/\*.*?\*/)*#;
		$PARSER = Parse::RecDescent->new($grammar);
		die("Failed to parse query grammar") unless defined($PARSER);
	}

	# since diagnostics/errors during actual parsing go to STDERR, we use an in memory trap for that
	# so we can present it the way we want it
	#
	my $parsedQuery;
	my $fieldRefs = [];
	my $errholder = IO::Scalar->new();
	{
		local *STDERR = $errholder;
		$parsedQuery = $PARSER->parsequery($query);
	}

	# if we didn't get a parse tree, the query syntax is probably wrong, so report that
	#
	if (!$parsedQuery)
	{
		# make sure we have some form of string, and make sure it doesn't end in a newline, since that
		# causes croak to drop the file/line information
		#
		my $capturedError = "$errholder" || 'UNKNOWN ERROR';
		do {} while (chomp($capturedError));
		croak($capturedError) unless $parsedQuery;
	}

	# we need the parse tree in a somewhat simplified and predigested format for the actual ops
	#
	__preprocessParsedQuery($parsedQuery, $fieldRefs);

	# ensure that the query either uses field names for every test, or not at all
	#
	my $oldFieldRefCount = scalar(@$fieldRefs);
	if ($oldFieldRefCount)
	{
		@$fieldRefs = grep { defined($_) } @$fieldRefs;
		my $newFieldRefCount = scalar(@$fieldRefs);
		croak("Query must use field names for all matches or none") if ($newFieldRefCount && $newFieldRefCount != $oldFieldRefCount)
	}
	$fieldRefs = [ __uniq(@$fieldRefs) ];

	return ($parsedQuery, $fieldRefs);
}

# recursively dig down in the parse tree and simplify by removing items we don't really need,
# rename some to simpler forms, and predigest the tests
#
sub __preprocessParsedQuery
{
	my $parsedQuery = shift;
	my $fieldRefs = shift;

	my $r = reftype($parsedQuery);
	if ($r)
	{
		if ($r eq 'ARRAY')
		{
			foreach my $i (@$parsedQuery)
			{
				__preprocessParsedQuery($i, $fieldRefs);
			}
		}
		elsif ($r eq 'HASH')
		{
			delete($parsedQuery->{__RULE__});
			delete($parsedQuery->{lparen});

			foreach my $altk (grep(/^_alternation_/, keys(%$parsedQuery)))
			{
				my $alt = $parsedQuery->{$altk};
				delete($parsedQuery->{$altk});
				my $keep = 1;
				$keep = 0 if (ref($alt) eq 'ARRAY' && scalar(@$alt) == 0);
				$keep = 0 if (blessed($alt) && $alt->{rparen});
				if ($keep)
				{
					die("PRE-EXISTING '__ALT'?") if exists($parsedQuery->{__ALT});
					$parsedQuery->{__ALT} = $alt;
				}
			}

			foreach my $k (keys(%$parsedQuery))
			{
				# the actual tests needs to be predigested a bit - ensure the regexps are compiled, insert
				# subs that will do the actual comparisons etc.
				#
				if ($k eq 'field_op_value_test')
				{
					push(@$fieldRefs, $parsedQuery->{$k}->{field});
					my $op = $parsedQuery->{$k}->{op};
					if ($op eq 'true')
					{
						$parsedQuery->{$k}->{op} = sub { 1 };
					}
					elsif ($op eq 'false')
					{
						$parsedQuery->{$k}->{op} = sub { 0 };
					}
					elsif ($op eq 'defined')
					{
						$parsedQuery->{$k}->{op} = sub { defined($_[0]) ? 1 : 0 };
					}
					elsif ($op eq 'path')
					{
						my $key = $parsedQuery->{$k}->{value};
						$parsedQuery->{$k}->{op} = sub { scalar(dpath($key)->match($_[2]) ) };
					}
					elsif ($op eq 'exists')
					{
						my $key = $parsedQuery->{$k}->{value};
						$parsedQuery->{$k}->{op} = sub { ( defined($_[0]) && ref($_[0]) eq 'HASH' ) ? exists($_[0]->{$key}) : 0 };
					}
					elsif ($op eq 'type')
					{
						my $v = $parsedQuery->{$k}->{value};
						croak("Bad value for '$op' => '$v', must be one of: 'scalar', 'array' or 'hash'") unless $v =~ /^(?:scalar|array|hash)$/i;
						$parsedQuery->{$k}->{op} = sub { defined($_[0]) ? (lc($v) eq (lc(ref($_[0])) || 'scalar') ) : 0 };
					}
					elsif ($op =~ /^size(.+)/)
					{
						my $compop = $1;
						my $possibleNumber = $parsedQuery->{$k}->{value};
						croak("Not a number for '$op': '$possibleNumber'") unless looks_like_number($possibleNumber);
						my $comparator = __getAnonWithOp($compop);
						$parsedQuery->{$k}->{op} =
							sub
								{
									my $reftype = ref($_[0]);
									my $sz = ($reftype eq 'ARRAY')
												? scalar(@{$_[0]})
												: ($reftype eq 'HASH')
													? scalar(keys(%{$_[0]}))
													: length($_[0]);
									$comparator->($sz, $possibleNumber);
								};
					}
					elsif ($op =~ /^(?:regexp|=~)$/)
					{
						$parsedQuery->{$k}->{value} = __compileRx($parsedQuery->{$k}->{value});
						$parsedQuery->{$k}->{op} = __getAnonWithOp('=~');
					}
					elsif ($op =~ /^(?:eq|ne|[lg][te])$/)
					{
						$parsedQuery->{$k}->{op} = __getAnonWithOp($op);
					}
					elsif ($op =~ /^(?:[=!<>]=|<|>)$/)
					{
						my $possibleNumber = $parsedQuery->{$k}->{value};
						croak("Not a number for '$op': '$possibleNumber'") unless looks_like_number($possibleNumber);
						$parsedQuery->{$k}->{op} = __getAnonWithOp($op);
					}
					else
					{
						die("Unexpected op: '$op'");
					}
				}
				__preprocessParsedQuery($parsedQuery->{$k}, $fieldRefs);
			}
		}
	}

	return $parsedQuery;
}

# helpers
#
sub __uniq
{
	my %seen;
	grep( { !$seen{$_}++ } @_ );
}

sub __compileRx
{
	my $re = shift;

	my $cre;
	if (! eval { $cre = qr/$re/ })
	{
		$@ =~ /^(.+)\sat\s/;
		croak("Bad regular expression:\n  $re\n  $1");
	}

	return($cre);
}

sub __getAnonWithOp
{
	my $op = shift;

	return eval "sub { defined(\$_[0]) ? \$_[0] $op \$_[1] : 0 }";
}

1;

__DATA__