File Coverage

blib/lib/Soar/Production/Parser.pm

Criterion	Covered	Total	%
statement	71	75	94.6
branch	12	16	75.0
condition	2	3	66.6
subroutine	18	19	94.7
pod	5	5	100.0
total	108	118	91.5

#
# This file is part of Soar-Production
#
# This software is copyright (c) 2012 by Nathan Glenn.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Soar::Production::Parser;
# ABSTRACT: Parse Soar productions

use strict;
use warnings;
#needed for advanced regex expressions
use 5.010;

our $VERSION = '0.03'; # VERSION
use Exporter::Easy (
	OK => [qw(no_comment)]
);
use Soar::Production::Parser::PRDGrammar;
use Parse::RecDescent;
use Carp;
use Data::Dumper;



#a regular expression to split text into productions
my $splitter = qr/
	(sp\s+				#start with 'sp'
	\{					#opening brace
	  (					#save to $2
		 (?: 			#either
			\{ (?-1) \}	#more braces and recurse
			|			#or
			(?:			#group
				[^|{}]++	#not bar or braces
				|   		#or
				\| 			#a bar
				(?:			#group
					[^\\|]++	#no slashes or bars, no backtracking
					|			#or
					\\.			#slash anything
				)*+
				\|
			)++				#one or more, no backtracking
		 )*				#0 or more times
	  )					#end $2
	\}					#ending brace
	)					#end $1
/x;

__PACKAGE__->new->_run(shift) unless caller;

sub _run {
  my ($soarParser, $filePath) = @_;
  print Dumper($soarParser->productions(file => $filePath, parse => 1) );
  return;
}


sub new {
  my ($class) = @_;
  my $soarParser = bless {}, $class;
  $soarParser->_init;
  return $soarParser;
}

sub _init {
  my ($soarParser) = @_;
    $soarParser->{parser} = Parse::RecDescent->new($Soar::Production::Parser::PRDGrammar::GRAMMAR);

	#if you wish to debug the grammar, try turning on traces by uncommenting the following lines:
	# $::RD_TRACE = 1;
	# $::RD_HINT = 1;
	return;
}


sub productions {## no critic RequireArgUnpacking
    my ($soarParser) = shift;
	my %args = (
		parse	=> 0,
		text	=> undef,
		file	=> undef,
		@_
	);
	defined $args{text} or defined $args{file}
		or croak 'Must specify parameter \'file\' or \'text\' to extract productions.';

	if($args{text}){
		return $soarParser->_productions_from_text($args{text}, $args{parse});
	}
	if($args{file}){
		# print "$args{file}\n";
		return $soarParser->_productions_from_file($args{file}, $args{parse});
	}
}

sub _productions_from_text {
    my ( $soarParser, $text, $parse) = @_;

	#remove comments
	$text = no_comment($text);
	my $productions = _split_text(\$text);
	return $productions
		unless($parse);

	return $soarParser->get_parses($productions);
}

sub _productions_from_file {
    my ( $soarParser, $file, $parse) = @_;
    my $text = _readFile($file);

	my $productions = _split_text($text);
	return $productions
		unless($parse);

	return $soarParser->get_parses($productions);
}

#split text reference into production
sub _split_text {
	my ($text) = @_;
	#split the text into productions by looking for 'sp { ... }'
	my @productions;
	while($$text =~ /$splitter/g){
		# print "found production: $1";
		push @productions, $1;
	}
	return \@productions;
}


sub parse_text {
    my ( $soarParser, $text ) = @_;
    croak 'no text to parse!'
      unless defined $text;
    # $soarParser->{input} = \$text;
    return $soarParser->{parser}->parse($text);
}



sub get_parses {
	my ($soarParser, $productions) = @_;
	my @parses;
	for(@$productions){
		# print STDERR $_;
		push @parses, $soarParser->{parser}->parse($_);
	}
	return \@parses;
}

#argument should be an opened file handle
#returns string pointer to text
sub _readFile {
    my ($file) = @_;
    open my $fh, '<', $file
		or croak "Couldn't open $file";

    my $text = q();
    $text .= $_ while (<$fh>);

	close $fh;
	$text = no_comment($text);
    return \$text;
}


sub no_comment {
	my ($text) = @_;
	$text =~ s/
			(			#save in $1
				\|			#literal bar
				(?:			#group
					\\[|]		#an escaped bar
					|
					[^|]		#or anything but a literal bar
				)*		#zero or more of previous group
				\|			#literal bar
			)			#end $1
			|			#or
			(?:;\s*)?			# optional semicolon
			\#			# pound character
			.*			#followed by anything
		/			#replace with
			$1||''	# $1 or nothing (the quote if there was one;
					# no quote will simply remove matching comment)
		/xeg;
	return $text;
}
1;

__END__