File Coverage

blib/lib/Tree/Parser.pm

Criterion	Covered	Total	%
statement	121	124	97.5
branch	57	62	91.9
condition	24	32	75.0
subroutine	21	22	95.4
pod	13	13	100.0
total	236	253	93.2

package Tree::Parser;

use strict;
use warnings;

our $VERSION = '0.15';

use Scalar::Util qw(blessed);

use Tree::Simple;
use Array::Iterator;

### constructor

sub new {
	my ($_class, $input) = @_;
	my $class = ref($_class) || $_class;
	my $tree_parser = {};
	bless($tree_parser, $class);
    $tree_parser->_init($input);
	return $tree_parser;
}

sub _init {
    my ($self, $input) = @_;
    # make slots for our 2 filters
    $self->{parse_filter} = undef;
    $self->{deparse_filter} = undef;
    $self->{deparse_filter_cleanup} = undef;
    # check the input and decide what to
    # do with it
    if ($input) {
        # we accept a Tree::Simple object
        # and expect then it to be deparsed
        if (blessed($input) && $input->isa("Tree::Simple")) {
            $self->{iterator} = undef;
            $self->{tree} = $input;
        }
        # or we can take a number of types of input
        # see prepareInput below
        else {
            $self->{iterator} = $self->prepareInput($input);
            $self->{tree} = Tree::Simple->new(Tree::Simple->ROOT);
        }
    }
    # if no input is given we create
    # an empty tree a no iterator
    else {
        $self->{iterator} = undef;
        $self->{tree} = Tree::Simple->new(Tree::Simple->ROOT);
    }
}

### methods

sub setFileEncoding {
    my ($self, $file_encoding) = @_;
    (defined($file_encoding)) || die "Insufficient Arguments : file_encoding must be defined";
    $self->{file_encoding} = $file_encoding;
}

sub setInput {
    my ($self, $input) = @_;
    (defined($input)) || die "Insufficient Arguments : input undefined";
    $self->{iterator} = $self->prepareInput($input);
}

# prepareInput accepts any of the follow
# types of arguments:
# 	- a .tree file
# 	- an array reference of lines
# 	- a single string of code (can have embedded newlines)
# and then returns an iterator.
# references will be stringified, unless they are array references or
# Array::Iterator objects.
sub prepareInput {
	my ($self, $input) = @_;

    # already an A:I instance
    return $input
        if blessed($input) and $input->isa('Array::Iterator');

    # a simple array
    return Array::Iterator->new($input)
        if ref($input) eq 'ARRAY';

    # stringifies to something that ends in .tree
	if ($input =~ /\.tree$/) {
	    IS_A_FILE:
	        my $encoding = (defined $self->{file_encoding}
	            ? (":" . $self->{file_encoding})
	            : '');
    		open(TREE_FILE, ("<" . $encoding), $input) || die "cannot open file: $!";
    		my @lines = ;
    		close(TREE_FILE);
    		return Array::Iterator->new(@lines);
	}
    # everything else
	else {
        my @lines;
        if ($input =~ /\n/) {
            @lines = split /\n/ => $input;
            (scalar(@lines) > 1)
                || die "Incorrect Object Type : input looked like a single string, but only a single line ($input) unable to parse input into line (" . (join "==" => @lines) . ")";
        }
        elsif ($input =~ /^\(/) {
            @lines = grep { $_ ne "" } split /(\(|\)|\s|\")/ => $input; #"
        }
        else {
            # lets check if it is a file though
            goto IS_A_FILE if -f $input;
            # otherwise, croak on this sucker ...
            die "Incorrect Object Type : input looked like a single string, but has no newlines or does not start with paren";
        }
		return Array::Iterator->new(@lines);
	}
}

## ----------------------------------------------------------------------------
## Filters
## ----------------------------------------------------------------------------

## tab indented filters
## ----------------------------------------------
{
    my $TAB_INDENTED_PARSE = sub ($) {
        my ($line_iterator) = @_;
        my $line = $line_iterator->next();
        my ($tabs, $node) = $line =~ /(\t*)(.*)/;
        my $depth = length $tabs;
        return ($depth, $node);
    };

    my $TAB_INDENTED_DEPARSE = sub ($) {
        my ($tree) = @_;
        return ("\t" x $tree->getDepth()) . $tree->getNodeValue();
    };

    sub useTabIndentedFilters {
        my ($self) = @_;
        $self->{parse_filter} = $TAB_INDENTED_PARSE;
        $self->{deparse_filter} = $TAB_INDENTED_DEPARSE;
        $self->{deparse_filter_cleanup} = undef;
    }
}

## space indented filters
## ----------------------------------------------
{
    my $make_SPACE_INDENTED_PARSE = sub {
        my ($num_spaces) = @_;
        return sub ($) {
            my ($line_iterator) = @_;
            my $line = $line_iterator->next();
            my ($spaces, $node) = $line =~ /(\s*)(.*)/;
            my $depth = (length($spaces) / $num_spaces) ;
            return ($depth, $node);
            };
    };

    my $make_SPACE_INDENTED_DEPARSE = sub {
        my ($num_spaces) = @_;
        my $spaces = (" " x $num_spaces);
        return sub ($) {
                my ($tree) = @_;
                return ($spaces x $tree->getDepth()) . $tree->getNodeValue();
            };
    };

    sub useSpaceIndentedFilters {
        my ($self, $num_spaces) = @_;
        $num_spaces ||= 4;
        $self->{parse_filter} = $make_SPACE_INDENTED_PARSE->($num_spaces);
        $self->{deparse_filter} = $make_SPACE_INDENTED_DEPARSE->($num_spaces);
        $self->{deparse_filter_cleanup} = undef;
    }
}

## space indented filters
## ----------------------------------------------
{

    my @default_level_identifiers = (1 .. 100);

    my $make_DOT_SEPERATED_LEVEL_PARSE = sub {
        my (@level_identifiers) = @_;
        @level_identifiers = @default_level_identifiers unless @level_identifiers;
        return sub {
            my ($line_iterator) = @_;
            my $line = $line_iterator->next();
            my $level_identifiers_reg_ex = join "|" => @level_identifiers;
            my ($numbers, $value) = $line =~ /([($level_identifiers_reg_ex)\.]*)\s(.*)/;
            # now split the numbers
            my @numbers = split /\./ => $numbers;
            # we know the depth of the tree by home many
            # numbers are present, and we assume we were
            # given them in sequential order anyway
            my $depth = $#numbers;
            return ($depth, $value);
        };
    };

    my $make_DOT_SEPERATED_LEVEL_DEPARSE = sub {
        my (@level_identifiers) = @_;
        @level_identifiers = @default_level_identifiers unless @level_identifiers;
        return sub {
            my ($tree) = @_;
            my @numbers = $level_identifiers[$tree->getIndex()];
            my $current_tree = $tree->getParent();
            until ($current_tree->isRoot()) {
                unshift @numbers => $level_identifiers[$current_tree->getIndex()];
                $current_tree = $current_tree->getParent();
            }
            return ((join "." => @numbers) . " " . $tree->getNodeValue());
        };
    };

    sub useDotSeparatedLevelFilters {
        my ($self, @level_identifiers) = @_;
        $self->{parse_filter} = $make_DOT_SEPERATED_LEVEL_PARSE->(@level_identifiers);
        $self->{deparse_filter} = $make_DOT_SEPERATED_LEVEL_DEPARSE->(@level_identifiers);
        $self->{deparse_filter_cleanup} = undef;
    }

    *useDotSeperatedLevelFilters = \&useDotSeparatedLevelFilters;

}

## nested parens filters
## ----------------------------------------------
{

    my $make_NESTED_PARENS_PARSE = sub {
        my @paren_stack;
        return sub {
            my ($line_iterator) = @_;
            my $line = $line_iterator->next();
            my $node = "";
            while (!$node && $node ne 0) {
                if ($line eq "(") {
                    push @paren_stack => $line;
                    last unless $line_iterator->hasNext();
                    $line = $line_iterator->next();
                }
                elsif ($line eq ")") {
                    pop @paren_stack;
                    last unless $line_iterator->hasNext();
                    $line = $line_iterator->next();
                }
                elsif ($line eq '"') {
                    $line = ""; # clear the quote
                    while ($line_iterator->hasNext()) {
                        my $next = $line_iterator->next();
                        last if $next eq '"';
                        $line .= $next;
                    }
                }
                elsif ($line eq ' ') {
                    # discard misc whitespace
                    $line = $line_iterator->next();
                    next;
                }
                else {
                    $node = $line;
                }
            }
            my $depth = $#paren_stack;
            $depth = 0 if $depth < 0;
            return ($depth, $node);
        };
    };

    # this is used in clean up as well
    my $prev_depth;
    my $NESTED_PARENS_DEPARSE = sub {
        my ($tree) = @_;
        my $output = "";
        unless (defined($prev_depth)) {
            $output .= "(";
            $prev_depth = $tree->getDepth();
        }
        else {
            my $current_depth = $tree->getDepth();
            if ($prev_depth == $current_depth) {
                $output .= " ";
            }
            elsif ($prev_depth < $current_depth) {
                $output .= " (";
            }
            elsif ($prev_depth > $current_depth) {
                my $delta = $prev_depth - $current_depth;
                $output .= ")" x $delta . " ";
            }
            $prev_depth = $current_depth;
        }
        my $current_node = $tree->getNodeValue();
        $current_node = '"' . $current_node . '"' if $current_node =~ /\s/;
        $output .= $current_node;
        return $output;
    };

    my $NESTED_PARENS_CLEANUP = sub {
        my $closing_parens = $prev_depth;
        # unset this so it can be used again
        undef $prev_depth;
        return @_, (")" x ($closing_parens + 1))
    };

    sub useNestedParensFilters {
        my ($self) = @_;
        $self->{parse_filter} = $make_NESTED_PARENS_PARSE->();
        $self->{deparse_filter} = $NESTED_PARENS_DEPARSE;
        $self->{deparse_filter_cleanup} = $NESTED_PARENS_CLEANUP;
    }
}

## manual filters
## ----------------------------------------------
# a filter is a subroutine reference
# which gets executed upon each line
# and it must return two values:
# 	- the depth of the node
# 	- the value of the node (which can
#	  be anything; string, array ref,
# 	  object instanace, you name it)
# NOTE:
# if a filter is not specified, then
# the parsers iterator is expected to
# return the dual values.

sub setParseFilter {
	my ($self, $filter) = @_;
	(defined($filter) && ref($filter) eq "CODE")
        || die "Insufficient Arguments : parse filter must be a code reference";
	$self->{parse_filter} = $filter;
}

sub setDeparseFilter {
	my ($self, $filter) = @_;
	(defined($filter) && ref($filter) eq "CODE")
        || die "Insufficient Arguments : parse filter must be a code reference";
	$self->{deparse_filter} = $filter;
}

## ----------------------------------------------------------------------------

sub getTree {
	my ($self) = @_;
	return $self->{tree};
}

# deparse creates either:
# 	- an array of lines
# 	- or one large string
# which contains the values
# created by the sub ref
# (unfilter) passed as an argument
sub deparse {
	my ($self) = @_;
	(defined($self->{deparse_filter}))
        || die "Parse Error : no deparse filter is specified";
	(!$self->{tree}->isLeaf())
        || die "Parse Error : Tree is a leaf node, cannot de-parse a tree that has not be created yet";
    return $self->_deparse();
}

# parser front end
sub parse {
	my ($self) = @_;
    (defined($self->{parse_filter}))
        || die "Parse Error : No parse filter is specified to parse with";
	(defined($self->{iterator}))
        || die "Parse Error : no input has yet been defined, there is nothing to parse";
	return $self->_parse();
}

## private methods

sub _deparse {
    my ($self) = @_;
	my @lines;
	$self->{tree}->traverse(sub {
		my ($tree) = @_;
		push @lines => $self->{deparse_filter}->($tree);
		});
    @lines = $self->{deparse_filter_cleanup}->(@lines) if defined $self->{deparse_filter_cleanup};
	return wantarray ?
				@lines
				:
				join("\n" => @lines);
}

# private method which parses given
# an iterator and a tree
sub _parse {
	my ($self) = @_;
    my $tree_type = ref($self->{tree});
    my ($i, $current_tree) = ($self->{iterator}, $self->{tree});
	while ($i->hasNext()) {
        my ($depth, $node) = $self->{parse_filter}->($i);
        # if we get nothing back and the iterator
        # is exhausted, then we now it is time to
        # stop parsing the input.
        last if !$depth && !$node && !$i->hasNext();
		# depth must be defined ...
		(defined($depth)
			&&
			# and a digit (int or float)
			($depth =~ /^\d+(\.\d*)?$/o)
			# otherwise we throw and exception
			) || die "Parse Error : Incorrect Value for depth (" . ((defined $depth) ? $depth : "undef") . ")";
		# and node is fine as long as it is defined
		(defined($node)) || die "Parse Error : node is not defined";

        my $new_tree;
        # if we get back a tree of the same type,
        # or even of a different type, but still
        # a Tree::Simple, then we use that ....
        if (blessed($node) && ($node->isa($tree_type) || $node->isa('Tree::Simple'))) {
            $new_tree = $node;
        }
        # othewise, we assume it is intended to be
        # the node of the tree
        else {
            $new_tree = $tree_type->new($node);
        }

		if ($current_tree->isRoot()) {
			$current_tree->addChild($new_tree);
			$current_tree = $new_tree;
			next;
		}
		my $tree_depth = $current_tree->getDepth();
		if ($depth == $tree_depth) {
			$current_tree->addSibling($new_tree);
			$current_tree = $new_tree;
		}
		elsif ($depth > $tree_depth) {
			(($depth - $tree_depth) <= 1)
                || die "Parse Error : the difference between the depth ($depth) and the tree depth ($tree_depth) is too much (" . ($depth - $tree_depth) . ") at '$node'";
			$current_tree->addChild($new_tree);
			$current_tree = $new_tree;
		}
		elsif ($depth < $tree_depth) {
			$current_tree = $current_tree->getParent() while ($depth < $current_tree->getDepth());
			$current_tree->addSibling($new_tree);
			$current_tree = $new_tree;
		}

	}
	return $self->{tree};
}

1;

__END__