# (c) Parse::Eyapp Copyright 2006-2008 Casiano Rodriguez-Leon, all rights reserved.
package Parse::Eyapp::Node;
use strict;
use Carp;
no warnings 'recursion';
use Parse::Eyapp::YATW;
use List::Util qw(first);
use Data::Dumper;
our $FILENAME=__FILE__;
sub firstval(&@) {
my $handler = shift;
return (grep { $handler->($_) } @_)[0]
}
sub lastval(&@) {
my $handler = shift;
return (grep { $handler->($_) } @_)[-1]
}
####################################################################
# Usage :
# line: %name PROG
# exp <%name EXP + ';'>
# { @{$lhs->{t}} = map { $_->{t}} ($lhs->child(0)->children()); }
# ;
# Returns : The array of children of the node. When the tree is a
# translation scheme the CODE references are also included
# Parameters : the node (method)
# See Also : Children
sub children {
my $self = CORE::shift;
return () unless UNIVERSAL::can($self, 'children');
@{$self->{children}} = @_ if @_;
@{$self->{children}}
}
####################################################################
# Usage : line: %name PROG
# (exp) <%name EXP + ';'>
# { @{$lhs->{t}} = map { $_->{t}} ($_[1]->Children()); }
#
# Returns : The true children of the node, excluding CODE CHILDREN
# Parameters : The Node object
sub Children {
my $self = CORE::shift;
return () unless UNIVERSAL::can($self, 'children');
@{$self->{children}} = @_ if @_;
grep { !UNIVERSAL::isa($_, 'CODE') } @{$self->{children}}
}
####################################################################
# Returns : Last non CODE child
# Parameters : the node object
sub Last_child {
my $self = CORE::shift;
return unless UNIVERSAL::can($self, 'children') and @{$self->{children}};
my $i = -1;
$i-- while defined($self->{children}->[$i]) and UNIVERSAL::isa($self->{children}->[$i], 'CODE');
return $self->{children}->[$i];
}
sub last_child {
my $self = CORE::shift;
return unless UNIVERSAL::can($self, 'children') and @{$self->{children}};
${$self->{children}}[-1];
}
####################################################################
# Usage : $node->child($i)
# my $transform = Parse::Eyapp::Treeregexp->new( STRING => q{
# commutative_add: PLUS($x, ., $y, .)
# => { my $t = $x; $_[0]->child(0, $y); $_[0]->child(2, $t)}
# }
# Purpose : Setter-getter to modify a specific child of a node
# Returns : Child with index $i. Returns undef if the child does not exists
# Parameters : Method: the node and the index of the child. The new value is used
# as a setter.
# Throws : Croaks if the index parameter is not provided
sub child {
my ($self, $index, $value) = @_;
#croak "$self is not a Parse::Eyapp::Node" unless $self->isa('Parse::Eyapp::Node');
return undef unless UNIVERSAL::can($self, 'child');
croak "Index not provided" unless defined($index);
$self->{children}[$index] = $value if defined($value);
$self->{children}[$index];
}
sub descendant {
my $self = shift;
my $coord = shift;
my @pos = split /\./, $coord;
my $t = $self;
my $x = shift(@pos); # discard the first empty dot
for (@pos) {
croak "Error computing descendant: $_ is not a number\n"
unless m{\d+} and $_ < $t->children;
$t = $t->child($_);
}
return $t;
}
####################################################################
# Usage : $node->s(@transformationlist);
# Example : The following example simplifies arithmetic expressions
# using method "s":
# > cat Timeszero.trg
# /* Operator "and" has higher priority than comma "," */
# whatever_times_zero: TIMES(@b, NUM($x) and { $x->{attr} == 0 }) => { $_[0] = $NUM }
#
# > treereg Timeszero
# > cat arrays.pl
# !/usr/bin/perl -w
# use strict;
# use Rule6;
# use Parse::Eyapp::Treeregexp;
# use Timeszero;
#
# my $parser = new Rule6();
# my $t = $parser->Run;
# $t->s(@Timeszero::all);
#
#
# Returns : Nothing
# Parameters : The object (is a method) and the list of transformations to apply.
# The list may be a list of Parse::Eyapp:YATW objects and/or CODE
# references
# Throws : No exceptions
# Comments : The set of transformations is repeatedly applied to the node
# until there are no changes.
# The function may hang if the set of transformations
# matches forever.
# See Also : The "s" method for Parse::Eyapp::YATW objects
# (i.e. transformation objects)
sub s {
my @patterns = @_[1..$#_];
# Make them Parse::Eyapp:YATW objects if they are CODE references
@patterns = map { ref($_) eq 'CODE'?
Parse::Eyapp::YATW->new(
PATTERN => $_,
#PATTERN_ARGS => [],
)
:
$_
}
@patterns;
my $changes;
do {
$changes = 0;
foreach (@patterns) {
$_->{CHANGES} = 0;
$_->s($_[0]);
$changes += $_->{CHANGES};
}
} while ($changes);
}
####################################################################
# Usage : ????
# Purpose : bud = Bottom Up Decoration: Decorates the tree with flowers :-)
# The purpose is to decorate the AST with attributes during
# the context-dependent analysis, mainly type-checking.
# Returns : ????
# Parameters : The transformations.
# Throws : no exceptions
# Comments : The tree is traversed bottom-up. The set of
# transformations is applied to each node in the order
# supplied by the user. As soon as one succeeds
# no more transformations are applied.
# See Also : n/a
# To Do : Avoid closure. Save @patterns inside the object
{
my @patterns;
sub bud {
@patterns = @_[1..$#_];
@patterns = map { ref($_) eq 'CODE'?
Parse::Eyapp::YATW->new(
PATTERN => $_,
#PATTERN_ARGS => [],
)
:
$_
}
@patterns;
_bud($_[0], undef, undef);
}
sub _bud {
my $node = $_[0];
my $index = $_[2];
# Is an odd leaf. Not actually a Parse::Eyapp::Node. Decorate it and leave
if (!ref($node) or !UNIVERSAL::can($node, "children")) {
for my $p (@patterns) {
return if $p->pattern->(
$_[0], # Node being visited
$_[1], # Father of this node
$index, # Index of this node in @Father->children
$p, # The YATW pattern object
);
}
};
# Recursively decorate subtrees
my $i = 0;
for (@{$node->{children}}) {
$_->_bud($_, $_[0], $i);
$i++;
}
# Decorate the node
#Change YATW object to be the first argument?
for my $p (@patterns) {
return if $p->pattern->($_[0], $_[1], $index, $p);
}
}
} # closure for @patterns
####################################################################
# Usage :
# @t = Parse::Eyapp::Node->new( q{TIMES(NUM(TERMINAL), NUM(TERMINAL))},
# sub {
# our ($TIMES, @NUM, @TERMINAL);
# $TIMES->{type} = "binary operation";
# $NUM[0]->{type} = "int";
# $NUM[1]->{type} = "float";
# $TERMINAL[1]->{attr} = 3.5;
# },
# );
# Purpose : Multi-Constructor
# Returns : Array of pointers to the objects created
# in scalar context a pointer to the first node
# Parameters : The class plus the string description and attribute handler
{
my %cache;
sub m_bless {
my $key = join "",@_;
my $class = shift;
return $cache{$key} if exists $cache{$key};
my $b = bless { children => \@_}, $class;
$cache{$key} = $b;
return $b;
}
}
sub _bless {
my $class = shift;
my $b = bless { children => \@_ }, $class;
return $b;
}
sub hexpand {
my $class = CORE::shift;
my $handler = CORE::pop if ref($_[-1]) eq 'CODE';
my $n = m_bless(@_);
my $newnodeclass = CORE::shift;
no strict 'refs';
push @{$newnodeclass."::ISA"}, 'Parse::Eyapp::Node' unless $newnodeclass->isa('Parse::Eyapp::Node');
if (defined($handler) and UNIVERSAL::isa($handler, "CODE")) {
$handler->($n);
}
$n;
}
sub hnew {
my $blesser = \&m_bless;
return _new($blesser, @_);
}
# Regexp for a full Perl identifier
sub _new {
my $blesser = CORE::shift;
my $class = CORE::shift;
local $_ = CORE::shift; # string: tree description
my $handler = CORE::shift if ref($_[0]) eq 'CODE';
my %classes;
my $b;
#TODO: Shall I receive a prefix?
my (@stack, @index, @results, %results, @place, $open);
#skip white spaces
s{\A\s+}{};
while ($_) {
# If is a leaf is followed by parenthesis or comma or an ID
s{\A([A-Za-z_][A-Za-z0-9_:]*)\s*([),])}
{$1()$2} # ... then add an empty pair of parenthesis
and do {
next;
};
# If is a leaf is followed by an ID
s{\A([A-Za-z_][A-Za-z0-9_:]*)\s+([A-Za-z_])}
{$1()$2} # ... then add an empty pair of parenthesis
and do {
next;
};
# If is a leaf at the end
s{\A([A-Za-z_][A-Za-z0-9_:]*)\s*$}
{$1()} # ... then add an empty pair of parenthesis
and do {
$classes{$1} = 1;
next;
};
# Is an identifier
s{\A([A-Za-z_][A-Za-z0-9_:]*)}{}
and do {
$classes{$1} = 1;
CORE::push @stack, $1;
next;
};
# Open parenthesis: mark the position for when parenthesis closes
s{\A[(]}{}
and do {
my $pos = scalar(@stack);
CORE::push @index, $pos;
$place[$pos] = $open++;
# Warning! I don't know what I am doing
next;
};
# Skip commas
s{\A,}{} and next;
# Closing parenthesis: time to build a node
s{\A[)]}{} and do {
croak "Syntax error! Closing parenthesis has no left partner!" unless @index;
my $begin = pop @index; # check if empty!
my @children = splice(@stack, $begin);
my $class = pop @stack;
croak "Syntax error! Any couple of parenthesis must be preceded by an identifier"
unless (defined($class) and $class =~ m{^[a-zA-Z_][\w:]*$});
$b = $blesser->($class, @children);
CORE::push @stack, $b;
$results[$place[$begin]] = $b;
CORE::push @{$results{$class}}, $b;
next;
};
last unless $_;
#skip white spaces
croak "Error building Parse::Eyapp::Node tree at '$_'." unless s{\A\s+}{};
} # while
croak "Syntax error! Open parenthesis has no right partner!" if @index;
{
no strict 'refs';
for (keys(%classes)) {
push @{$_."::ISA"}, 'Parse::Eyapp::Node' unless $_->isa('Parse::Eyapp::Node');
}
}
if (defined($handler) and UNIVERSAL::isa($handler, "CODE")) {
$handler->(@results);
}
return wantarray? @results : $b;
}
sub new {
my $blesser = \&_bless;
_new($blesser, @_);
}
## Used by _subtree_list
#sub compute_hierarchy {
# my @results = @{shift()};
#
# # Compute the hierarchy
# my $b;
# my @r = @results;
# while (@results) {
# $b = pop @results;
# my $d = $b->{depth};
# my $f = lastval { $_->{depth} < $d} @results;
#
# $b->{father} = $f;
# $b->{children} = [];
# unshift @{$f->{children}}, $b;
# }
# $_->{father} = undef for @results;
# bless $_, "Parse::Eyapp::Node::Match" for @r;
# return @r;
#}
# Matches
sub m {
my $self = shift;
my @patterns = @_ or croak "Expected a pattern!";
croak "Error in method m of Parse::Eyapp::Node. Expected Parse::Eyapp:YATW patterns"
unless $a = first { !UNIVERSAL::isa($_, "Parse::Eyapp:YATW") } @_;
# array context: return all matches
local $a = 0;
my %index = map { ("$_", $a++) } @patterns;
my @stack = (
Parse::Eyapp::Node::Match->new(
node => $self,
depth => 0,
dewey => "",
patterns =>[]
)
);
my @results;
do {
my $mn = CORE::shift(@stack);
my %n = %$mn;
# See what patterns do match the current $node
for my $pattern (@patterns) {
push @{$mn->{patterns}}, $index{$pattern} if $pattern->{PATTERN}($n{node});
}
my $dewey = $n{dewey};
if (@{$mn->{patterns}}) {
$mn->{family} = \@patterns;
# Is at this time that I have to compute the father
my $f = lastval { $dewey =~ m{^$_->{dewey}}} @results;
$mn->{father} = $f;
# ... and children
push @{$f->{children}}, $mn if defined($f);
CORE::push @results, $mn;
}
my $childdepth = $n{depth}+1;
my $k = -1;
CORE::unshift @stack,
map
{
$k++;
Parse::Eyapp::Node::Match->new(
node => $_,
depth => $childdepth,
dewey => "$dewey.$k",
patterns => []
)
} $n{node}->children();
} while (@stack);
wantarray? @results : $results[0];
}
#sub _subtree_scalar {
# # scalar context: return iterator
# my $self = CORE::shift;
# my @patterns = @_ or croak "Expected a pattern!";
#
# # %index gives the index of $p in @patterns
# local $a = 0;
# my %index = map { ("$_", $a++) } @patterns;
#
# my @stack = ();
# my $mn = { node => $self, depth => 0, patterns =>[] };
# my @results = ();
#
# return sub {
# do {
# # See if current $node matches some patterns
# my $d = $mn->{depth};
# my $childdepth = $d+1;
# # See what patterns do match the current $node
# for my $pattern (@patterns) {
# push @{$mn->{patterns}}, $index{$pattern} if $pattern->{PATTERN}($mn->{node});
# }
#
# if (@{$mn->{patterns}}) { # matched
# CORE::push @results, $mn;
#
# # Compute the hierarchy
# my $f = lastval { $_->{depth} < $d} @results;
# $mn->{father} = $f;
# $mn->{children} = [];
# $mn->{family} = \@patterns;
# unshift @{$f->{children}}, $mn if defined($f);
# bless $mn, "Parse::Eyapp::Node::Match";
#
# # push children in the stack
# CORE::unshift @stack,
# map { { node => $_, depth => $childdepth, patterns => [] } }
# $mn->{node}->children();
# $mn = CORE::shift(@stack);
# return $results[-1];
# }
# # didn't match: push children in the stack
# CORE::unshift @stack,
# map { { node => $_, depth => $childdepth, patterns => [] } }
# $mn->{node}->children();
# $mn = CORE::shift(@stack);
# } while ($mn); # May be the stack is empty now, but if $mn then there is a node to process
# # reset iterator
# my @stack = ();
# my $mn = { node => $self, depth => 0, patterns =>[] };
# return undef;
# };
#}
# Factorize this!!!!!!!!!!!!!!
#sub m {
# goto &_subtree_list if (wantarray());
# goto &_subtree_scalar;
#}
####################################################################
# Usage : $BLOCK->delete($ASSIGN)
# $BLOCK->delete(2)
# Purpose : deletes the specified child of the node
# Returns : The deleted child
# Parameters : The object plus the index or pointer to the child to be deleted
# Throws : If the object can't do children or has no children
# See Also : n/a
sub delete {
my $self = CORE::shift; # The tree object
my $child = CORE::shift; # index or pointer
croak "Parse::Eyapp::Node::delete error, node:\n"
.Parse::Eyapp::Node::str($self)."\ndoes not have children"
unless UNIVERSAL::can($self, 'children') and ($self->children()>0);
if (ref($child)) {
my $i = 0;
for ($self->children()) {
last if $_ == $child;
$i++;
}
if ($i == $self->children()) {
warn "Parse::Eyapp::Node::delete warning: node:\n".Parse::Eyapp::Node::str($self)
."\ndoes not have a child like:\n"
.Parse::Eyapp::Node::str($child)
."\nThe node was not deleted!\n";
return $child;
}
splice(@{$self->{children}}, $i, 1);
return $child;
}
my $numchildren = $self->children();
croak "Parse::Eyapp::Node::delete error: expected an index between 0 and ".
($numchildren-1).". Got $child" unless ($child =~ /\d+/ and $child < $numchildren);
splice(@{$self->{children}}, $child, 1);
return $child;
}
####################################################################
# Usage : $BLOCK->shift
# Purpose : deletes the first child of the node
# Returns : The deleted child
# Parameters : The object
# Throws : If the object can't do children
# See Also : n/a
sub shift {
my $self = CORE::shift; # The tree object
croak "Parse::Eyapp::Node::shift error, node:\n"
.Parse::Eyapp::Node->str($self)."\ndoes not have children"
unless UNIVERSAL::can($self, 'children');
return CORE::shift(@{$self->{children}});
}
sub unshift {
my $self = CORE::shift; # The tree object
my $node = CORE::shift; # node to insert
CORE::unshift @{$self->{children}}, $node;
}
sub push {
my $self = CORE::shift; # The tree object
#my $node = CORE::shift; # node to insert
#CORE::push @{$self->{children}}, $node;
CORE::push @{$self->{children}}, @_;
}
sub insert_before {
my $self = CORE::shift; # The tree object
my $child = CORE::shift; # index or pointer
my $node = CORE::shift; # node to insert
croak "Parse::Eyapp::Node::insert_before error, node:\n"
.Parse::Eyapp::Node::str($self)."\ndoes not have children"
unless UNIVERSAL::can($self, 'children') and ($self->children()>0);
if (ref($child)) {
my $i = 0;
for ($self->children()) {
last if $_ == $child;
$i++;
}
if ($i == $self->children()) {
warn "Parse::Eyapp::Node::insert_before warning: node:\n"
.Parse::Eyapp::Node::str($self)
."\ndoes not have a child like:\n"
.Parse::Eyapp::Node::str($child)."\nThe node was not inserted!\n";
return $child;
}
splice(@{$self->{children}}, $i, 0, $node);
return $node;
}
my $numchildren = $self->children();
croak "Parse::Eyapp::Node::insert_before error: expected an index between 0 and ".
($numchildren-1).". Got $child" unless ($child =~ /\d+/ and $child < $numchildren);
splice(@{$self->{children}}, $child, 0, $node);
return $child;
}
sub insert_after {
my $self = CORE::shift; # The tree object
my $child = CORE::shift; # index or pointer
my $node = CORE::shift; # node to insert
croak "Parse::Eyapp::Node::insert_after error, node:\n"
.Parse::Eyapp::Node::str($self)."\ndoes not have children"
unless UNIVERSAL::can($self, 'children') and ($self->children()>0);
if (ref($child)) {
my $i = 0;
for ($self->children()) {
last if $_ == $child;
$i++;
}
if ($i == $self->children()) {
warn "Parse::Eyapp::Node::insert_after warning: node:\n"
.Parse::Eyapp::Node::str($self).
"\ndoes not have a child like:\n"
.Parse::Eyapp::Node::str($child)."\nThe node was not inserted!\n";
return $child;
}
splice(@{$self->{children}}, $i+1, 0, $node);
return $node;
}
my $numchildren = $self->children();
croak "Parse::Eyapp::Node::insert_after error: expected an index between 0 and ".
($numchildren-1).". Got $child" unless ($child =~ /\d+/ and $child < $numchildren);
splice(@{$self->{children}}, $child+1, 0, $node);
return $child;
}
{ # $match closure
my $match;
sub clean_tree {
$match = pop;
croak "clean tree: a node and code reference expected" unless (ref($match) eq 'CODE') and (@_ > 0);
$_[0]->_clean_tree();
}
sub _clean_tree {
my @children;
for ($_[0]->children()) {
next if (!defined($_) or $match->($_));
$_->_clean_tree();
CORE::push @children, $_;
}
$_[0]->{children} = \@children; # Bad code
}
} # $match closure
####################################################################
# Usage : $t->str
# Returns : Returns a string describing the Parse::Eyapp::Node as a term
# i.e., s.t. like: 'PROGRAM(FUNCTION(RETURN(TERMINAL,VAR(TERMINAL))))'
our @PREFIXES = qw(Parse::Eyapp::Node::);
our $INDENT = 0; # -1 new 0 = compact, 1 = indent, 2 = indent and include Types in closing parenthesis
our $STRSEP = ',';
our $DELIMITER = '[';
our $FOOTNOTE_HEADER = "\n---------------------------\n";
our $FOOTNOTE_SEP = ")\n";
our $FOOTNOTE_LEFT = '^{';
our $FOOTNOTE_RIGHT = '}';
our $LINESEP = 4;
our $CLASS_HANDLER = sub { type($_[0]) }; # What to print to identify the node
my %match_del = (
'[' => ']',
'{' => '}',
'(' => ')',
'<' => '>'
);
my $pair;
my $footnotes = '';
my $footnote_label;
sub str {
my @terms;
# Consume arg only if called as a class method Parse::Eyap::Node->str($node1, $node2, ...)
CORE::shift unless ref($_[0]);
for (@_) {
$footnote_label = 0;
$footnotes = '';
# Set delimiters for semantic values
if (defined($DELIMITER) and exists($match_del{$DELIMITER})) {
$pair = $match_del{$DELIMITER};
}
else {
$DELIMITER = $pair = '';
}
CORE::push @terms, _str($_).$footnotes;
}
return wantarray? @terms : $terms[0];
}
sub _str {
my $self = CORE::shift; # root of the subtree
my $indent = (CORE::shift or 0); # current depth in spaces " "
my @children = Parse::Eyapp::Node::children($self);
my @t;
my $res;
my $fn = $footnote_label;
if ($INDENT >= 0 && UNIVERSAL::can($self, 'footnote')) {
$res = $self->footnote;
$footnotes .= $FOOTNOTE_HEADER.$footnote_label++.$FOOTNOTE_SEP.$res if $res;
}
# recursively visit nodes
for (@children) {
CORE::push @t, Parse::Eyapp::Node::_str($_, $indent+2) if defined($_);
}
local $" = $STRSEP;
my $class = $CLASS_HANDLER->($self);
$class =~ s/^$_// for @PREFIXES;
my $information;
$information = $self->info if ($INDENT >= 0 && UNIVERSAL::can($self, 'info'));
$class .= $DELIMITER.$information.$pair if defined($information);
if ($INDENT >= 0 && $res) {
$class .= $FOOTNOTE_LEFT.$fn.$FOOTNOTE_RIGHT;
}
if ($INDENT > 0) {
my $w = " "x$indent;
$class = "\n$w$class";
$class .= "(@t\n$w)" if @children;
$class .= " # ".$CLASS_HANDLER->($self) if ($INDENT > 1) and ($class =~ tr/\n/\n/>$LINESEP);
}
else {
$class .= "(@t)" if @children;
}
return $class;
}
sub _dot {
my ($root, $number) = @_;
my $type = $root->type();
my $information;
$information = $root->info if ($INDENT >= 0 && $root->can('info'));
my $class = $CLASS_HANDLER->($root);
$class = qq{$class<font color="red">$DELIMITER$information$pair</font>} if defined($information);
my $dot = qq{ $number [label = <$class>];\n};
my $k = 0;
my @dots = map { $k++; $_->_dot("$number$k") } $root->children;
for($k = 1; $k <= $root->children; $k++) {;
$dot .= qq{ $number -> $number$k;\n};
}
return $dot.join('',@dots);
}
sub dot {
my $dot = $_[0]->_dot('0');
return << "EOGRAPH";
digraph G {
ordering=out
$dot
}
EOGRAPH
}
sub fdot {
my ($self, $file) = @_;
if ($file) {
$file .= '.dot' unless $file =~ /\.dot$/;
}
else {
$file = $self->type().".dot";
}
open my $f, "> $file";
print $f $self->dot();
close($f);
}
BEGIN {
my @dotFormats = qw{bmp canon cgimage cmap cmapx cmapx_np eps exr fig gd gd2 gif gv imap imap_np ismap jp2 jpe jpeg jpg pct pdf pict plain plain-ext png ps ps2 psd sgi svg svgz tga tif tiff tk vml vmlz vrml wbmp x11 xdot xlib};
for my $format (@dotFormats) {
no strict 'refs';
*{'Parse::Eyapp::Node::'.$format} = sub {
my ($self, $file) = @_;
$file = $self->type() unless defined($file);
$self->fdot($file);
$file =~ s/\.(dot|$format)$//;
my $dotfile = "$file.dot";
my $pngfile = "$file.$format";
my $err = qx{dot -T$format $dotfile -o $pngfile 2>&1};
return ($err, $?);
}
}
}
sub translation_scheme {
my $self = CORE::shift; # root of the subtree
my @children = $self->children();
for (@children) {
if (ref($_) eq 'CODE') {
$_->($self, $self->Children);
}
elsif (defined($_)) {
translation_scheme($_);
}
}
}
sub type {
my $type = ref($_[0]);
if ($type) {
if (defined($_[1])) {
$type = $_[1];
Parse::Eyapp::Driver::BeANode($type);
bless $_[0], $type;
}
return $type
}
return 'Parse::Eyapp::Node::STRING';
}
{ # Tree "fuzzy" equality
####################################################################
# Usage : $t1->equal($t2, n => sub { return $_[0] == $_[1] })
# Purpose : Checks the equality between two AST
# Returns : 1 if equal, 0 if not 'equal'
# Parameters : Two Parse::Eyapp:Node nodes and a hash of comparison handlers.
# The keys of the hash are the attributes of the nodes. The value is
# a comparator function. The comparator for key $k receives the attribute
# for the nodes being visited and rmust return true if they are considered similar
# Throws : exceptions if the parameters aren't Parse::Eyapp::Nodes
my %handler;
# True if the two trees look similar
sub equal {
croak "Parse::Eyapp::Node::equal error. Expected two syntax trees \n" unless (@_ > 1);
%handler = splice(@_, 2);
my $key = '';
defined($key=firstval {!UNIVERSAL::isa($handler{$_},'CODE') } keys %handler)
and
croak "Parse::Eyapp::Node::equal error. Expected a CODE ref for attribute $key\n";
goto &_equal;
}
sub _equal {
my $tree1 = CORE::shift;
my $tree2 = CORE::shift;
# Same type
return 0 unless ref($tree1) eq ref($tree2);
# Check attributes via handlers
for (keys %handler) {
# Check for existence
return 0 if (exists($tree1->{$_}) && !exists($tree2->{$_}));
return 0 if (exists($tree2->{$_}) && !exists($tree1->{$_}));
# Check for definition
return 0 if (defined($tree1->{$_}) && !defined($tree2->{$_}));
return 0 if (defined($tree2->{$_}) && !defined($tree1->{$_}));
# Check for equality
return 0 unless $handler{$_}->($tree1->{$_}, $tree2->{$_});
}
# Same number of children
my @children1 = @{$tree1->{children}};
my @children2 = @{$tree2->{children}};
return 0 unless @children1 == @children2;
# Children must be similar
for (@children1) {
my $ch2 = CORE::shift @children2;
return 0 unless _equal($_, $ch2);
}
return 1;
}
}
1;
package Parse::Eyapp::Node::Match;
our @ISA = qw(Parse::Eyapp::Node);
# A Parse::Eyapp::Node::Match object is a reference
# to a tree of Parse::Eyapp::Nodes that has been used
# in a tree matching regexp. You can think of them
# as the equivalent of $1 $2, ... in treeregexeps
# The depth of the Parse::Eyapp::Node being referenced
sub new {
my $class = shift;
my $matchnode = { @_ };
$matchnode->{children} = [];
bless $matchnode, $class;
}
sub depth {
my $self = shift;
return $self->{depth};
}
# The coordinates of the Parse::Eyapp::Node being referenced
sub coord {
my $self = shift;
return $self->{dewey};
}
# The Parse::Eyapp::Node being referenced
sub node {
my $self = shift;
return $self->{node};
}
# The Parse::Eyapp::Node:Match that references
# the nearest ancestor of $self->{node} that matched
sub father {
my $self = shift;
return $self->{father};
}
# The patterns that matched with $self->{node}
# Indexes
sub patterns {
my $self = shift;
@{$self->{patterns}} = @_ if @_;
return @{$self->{patterns}};
}
# The original list of patterns that produced this match
sub family {
my $self = shift;
@{$self->{family}} = @_ if @_;
return @{$self->{family}};
}
# The names of the patterns that matched
sub names {
my $self = shift;
my @indexes = $self->patterns;
my @family = $self->family;
return map { $_->{NAME} or "Unknown" } @family[@indexes];
}
sub info {
my $self = shift;
my $node = $self->node;
my @names = $self->names;
my $nodeinfo;
if (UNIVERSAL::can($node, 'info')) {
$nodeinfo = ":".$node->info;
}
else {
$nodeinfo = "";
}
return "[".ref($self->node).":".$self->depth.":@names$nodeinfo]"
}
1;