File Coverage

blib/lib/Zoidberg/StringParser.pm

Criterion	Covered	Total	%
statement	126	142	88.7
branch	76	90	84.4
condition	32	41	78.0
subroutine	6	6	100.0
pod	2	2	100.0
total	242	281	86.1

package Zoidberg::StringParser;

# Hic sunt leones.

our $VERSION = '0.981';

use strict;
no warnings; # can't stand the nagging
use Zoidberg::Utils qw/debug error bug/;

our $ERROR_CALLER = 1;

# TODO :
# esc per type ?

# how bout more general state machine approach,
#     making QUOTE and NEST operations like CUT, POP and RECURS

# grammar can be big hash (sort keys on length) .. how to deal with regexes than ?
#  ... optimise for normal string tokens, regexes are the exception
#  need seperate hashes for overloading

# how bout ->for(gram, string, int, sub) ? exec sub on token with most parser vars in scope
#   %state ?

sub new {
	my $class = shift;
	my $self = {
		base_gram  => shift || {},
		collection => shift || {},
		settings   => shift || {},
	};
	bless $self, $class;
	return $self;
}

sub split {
	my ($self, $gram, $input, $int) = @_;
	$int--; # 1 based => 0 based

	$$self{broken} = undef; # reset error

	debug "splitting with $gram";
	unless (ref $gram) {
		error "No such grammar: $gram" unless $$self{collection}{$gram};
		$gram = [$$self{collection}{$gram}]
	}
	elsif (ref($gram) eq 'ARRAY') {
		my $error;
		$gram = [ map {
			ref($_) ? $_ : ($$self{collection}{$_} || $error++)
		} @$gram ];
		error "No such grammar: $_" if $error;
	}
	else { $gram = [$gram] } # hash or regex
	unshift @$gram, $$self{base_gram};

	my ($expr, $types);
	($gram, $expr, $types) = $self->_prepare_gram($gram);
#	use Data::Dumper; print STDERR Dumper $gram, $expr, $types;

	my $string;
	if (ref($input) eq 'ARRAY') { $string = shift @$input }
	else { ($string, $input) = ("$input", []) } # quotes in case of overload

	return unless length $string or @$input;

	my ($block, @parts, @open, $i, $s_i); # $i counts splitted parts, $s_i the stack size

	PARSE_TOKEN:
	debug 'splitting string: '.$string;

	my ($token, $type, $sign);
	while ( !$token && $string =~ s{\A(.*?)($expr\z)}{}s ) {
		$block .= $1 if length $1;
		$sign = $2;

		my $i = 0;
		($_ eq $2) ? last : $i++ for ($3, $4, $5);
		$type = $$types[$i];

		last unless length $sign or length $string; # catch the \z

		if ($type eq 'd_esc') {
			debug "block: ==>$block<== token: ==>$sign<== type: $type";
			$block .= $sign;
			next;
		}

		# fetch token
		my $item;
		my ($slice) = grep exists($$_{$type}), reverse @$gram;
		if (ref($$slice{$type}[1]) eq 'ARRAY') { # for loop probably faster
			($item) = map $$_[1],
				grep {ref($$_[0]) ? ($sign =~ $$_[0]) : ($sign eq $$_[0])}
				@{$$slice{$type}[1]}
		}
		else { $item = $$slice{$type}[1]{$sign} }
		debug "block: ==>$block<== token: ==>$sign<== type: $type item: $item";
		$item = $sign if $item eq '_SELF';

		if (exists $$slice{s_esc} and $1 =~ /$$slice{s_esc}$/) {
			debug 'escaped token s_esc: '.$$slice{s_esc};
			$block =~ s/$$slice{s_esc}$//
		       		if $type eq 'tokens' and ! $$self{settings}{no_esc_rm};
			$block .= $sign;
			next;
		}

		if ($type eq 'tokens') {
			unless ($s_i) {
				if (ref $item) { # for $() matching tactics
					debug 'push stack (tokens)';
					push @$gram, $item;
					$s_i++;
					($gram, $expr, $types) = $self->_prepare_gram($gram);
					@open = ($sign, $type);
					$token = $$gram[-1]{token};
				}
				else { $token = $item }
			}
			else {
				if ($item eq '_POP') {
					$block .= $sign;
					debug "pop stack ($item)";
					pop @$gram;
					$s_i--;
				}
				elsif ($item eq '_CUT') { # for $() matching
					$token = $item;
					debug "cut stack ($item)";
					splice @$gram, -$s_i;
					$s_i = 0;
				}
				else { bug "what to do with $item !?" }
				($gram, $expr, $types) = $self->_prepare_gram($gram);
			}
		}
		else { # open nest or quote
			$block .= $sign;
			unless (ref $item) {
				if ($item eq '_REC') { $item = {} } # recurs UGLY
				else { # generate a grammar on the fly
					$item = ($type eq 'nests')
						? {
							tokens => {$item => '_POP'},
							nests => {$sign => '_REC'},
						} : {
							tokens => {$item => '_POP'},
							quotes => {$sign => '_REC'},
							nests => {},
						} ;
				}
			}
			# else if item is ref => item is grammar
			debug "push stack ($type)";
			push @$gram, $item;
			$s_i++;
			($gram, $expr, $types) = $self->_prepare_gram($gram);
			@open = ($sign, $type);
		}
		last unless length $string;
	}

	if (length $block) {
		my $part = $block; # force copy
		push @parts, \$part;
	}
	if ($token and $token ne '_CUT') { push @parts, $token }
	$block = $token = undef;

	if (($s_i or ++$i != $int) and length($string) || scalar(@$input)) {
		$string = shift @$input unless length $string;
		goto PARSE_TOKEN;
	}
	elsif ($i == $int) {
		my $part = join '', $string, @$input;
		push @parts, \$part;
	}

	if ($s_i) { # broken
		debug 'stack not empty';
		$open[1] =~ s/s$// ;
		$$self{broken} = "Unmatched $open[1] at end of input: $open[0]";
		error $$self{broken} unless $$self{settings}{allow_broken};
		pop @$gram for 1 .. $s_i;
	}

	return grep defined($_), map {ref($_) ? $$_ : $_} @parts
		if $$gram[-1]{was_regexp} && ! $$self{settings}{no_split_intel};
	return grep defined($_), @parts;
}

sub _prepare_gram { # index immediatly here
	my ($self, $gram) = @_;
	my %index;
	for my $ref (@$gram) { # prepare grammars for usage
		if (ref($ref) eq 'Regexp') {
			$ref = {tokens => [[$ref, '_CUT']], was_regexp => 1};
		}
		elsif (ref($ref) ne 'HASH') {
			error 'Grammar has wrong data type: '.ref($ref)."\n";
		}

		unless ($$ref{prepared}) {
			if (exists $$ref{esc}) {
				$$ref{s_esc} = ref($$ref{esc}) ? $$ref{esc}
					: quotemeta $$ref{esc};			# single esc regexp
				$$ref{d_esc} = '('.($$ref{s_esc}x2).')|';	# double esc regexp
			}
			elsif (! exists $$ref{s_esc} and exists $index{s_esc}) {
				$$ref{s_esc} = $index{s_esc};
			}

			for (qw/tokens nests quotes/) {
				next unless exists $$ref{$_};
				my $expr = (ref($$ref{$_}) eq 'ARRAY')
					? join( '|', map {
						ref($$_[0]) ? $$_[0] : quotemeta($$_[0])
					} @{$$ref{$_}} )
					: join( '|', map { quotemeta($_) } keys %{$$ref{$_}} ) ;
				$expr = $expr ? '('.$expr.')|' : '';
				$$ref{$_} = [$expr, $$ref{$_}];
			}
			$$ref{prepared}++;
		}

		$index{$_} = $$ref{$_}[0] for grep exists($$ref{$_}), qw/tokens nests quotes/;
		$index{$_} = $$ref{$_} for grep exists($$ref{$_}), qw/s_esc d_esc/;
	}

	my ($expr, @types) = ('');
	for (qw/d_esc tokens nests quotes/) {
		next unless length $index{$_};
		push @types, $_;
		$expr .= $index{$_};
	}
	return $gram, $expr, \@types;
}

1;

__END__