File Coverage

blib/lib/Parse/Eyapp/Node.pm
Criterion Covered Total %
statement 253 419 60.3
branch 83 190 43.6
condition 18 80 22.5
subroutine 37 58 63.7
pod 0 28 0.0
total 391 775 50.4


line stmt bran cond sub pod time code
1             # Copyright © 2006, 2007, 2008, 2009, 2010, 2011, 2012 Casiano Rodriguez-Leon.
2             # Copyright © 2017 William N. Braswell, Jr.
3             # All Rights Reserved.
4             #
5             # Parse::Yapp is Copyright © 1998, 1999, 2000, 2001, Francois Desarmenien.
6             # Parse::Yapp is Copyright © 2017 William N. Braswell, Jr.
7             # All Rights Reserved.
8             package Parse::Eyapp::Node;
9 64     64   2012 use strict;
  64         137  
  64         1749  
10 64     64   326 use Carp;
  64         130  
  64         3905  
11 64     64   361 no warnings 'recursion';
  64         133  
  64         2556  
12              
13 64     64   22381 use Parse::Eyapp::YATW;
  64         212  
  64         2018  
14 64     64   436 use List::Util qw(first);
  64         145  
  64         3014  
15 64     64   361 use Data::Dumper;
  64         128  
  64         60192  
16              
17             our $FILENAME=__FILE__;
18              
19             sub firstval(&@) {
20 2     2 0 2 my $handler = shift;
21            
22 2         6 return (grep { $handler->($_) } @_)[0]
  1         3  
23             }
24              
25             sub lastval(&@) {
26 7     7 0 14 my $handler = shift;
27            
28 7         19 return (grep { $handler->($_) } @_)[-1]
  5         13  
29             }
30              
31             ####################################################################
32             # Usage :
33             # line: %name PROG
34             # exp <%name EXP + ';'>
35             # { @{$lhs->{t}} = map { $_->{t}} ($lhs->child(0)->children()); }
36             # ;
37             # Returns : The array of children of the node. When the tree is a
38             # translation scheme the CODE references are also included
39             # Parameters : the node (method)
40             # See Also : Children
41              
42             sub children {
43 1933     1933 0 4317 my $self = CORE::shift;
44            
45 1933 50       6056 return () unless UNIVERSAL::can($self, 'children');
46 1933 50       4652 @{$self->{children}} = @_ if @_;
  0         0  
47 1933         2790 @{$self->{children}}
  1933         5701  
48             }
49              
50             ####################################################################
51             # Usage : line: %name PROG
52             # (exp) <%name EXP + ';'>
53             # { @{$lhs->{t}} = map { $_->{t}} ($_[1]->Children()); }
54             #
55             # Returns : The true children of the node, excluding CODE CHILDREN
56             # Parameters : The Node object
57              
58             sub Children {
59 128     128 0 184 my $self = CORE::shift;
60            
61 128 50       352 return () unless UNIVERSAL::can($self, 'children');
62              
63 128 50       271 @{$self->{children}} = @_ if @_;
  0         0  
64 128         178 grep { !UNIVERSAL::isa($_, 'CODE') } @{$self->{children}}
  386         1085  
  128         215  
65             }
66              
67             ####################################################################
68             # Returns : Last non CODE child
69             # Parameters : the node object
70              
71             sub Last_child {
72 1     1 0 7 my $self = CORE::shift;
73              
74 1 50 33     6 return unless UNIVERSAL::can($self, 'children') and @{$self->{children}};
  1         5  
75 1         3 my $i = -1;
76 1   33     8 $i-- while defined($self->{children}->[$i]) and UNIVERSAL::isa($self->{children}->[$i], 'CODE');
77 1         4 return $self->{children}->[$i];
78             }
79              
80             sub last_child {
81 0     0 0 0 my $self = CORE::shift;
82              
83 0 0 0     0 return unless UNIVERSAL::can($self, 'children') and @{$self->{children}};
  0         0  
84 0         0 ${$self->{children}}[-1];
  0         0  
85             }
86              
87             ####################################################################
88             # Usage : $node->child($i)
89             # my $transform = Parse::Eyapp::Treeregexp->new( STRING => q{
90             # commutative_add: PLUS($x, ., $y, .)
91             # => { my $t = $x; $_[0]->child(0, $y); $_[0]->child(2, $t)}
92             # }
93             # Purpose : Setter-getter to modify a specific child of a node
94             # Returns : Child with index $i. Returns undef if the child does not exists
95             # Parameters : Method: the node and the index of the child. The new value is used
96             # as a setter.
97             # Throws : Croaks if the index parameter is not provided
98             sub child {
99 1291     1291 0 3219 my ($self, $index, $value) = @_;
100            
101             #croak "$self is not a Parse::Eyapp::Node" unless $self->isa('Parse::Eyapp::Node');
102 1291 50       3645 return undef unless UNIVERSAL::can($self, 'child');
103 1291 50       2875 croak "Index not provided" unless defined($index);
104 1291 50       2628 $self->{children}[$index] = $value if defined($value);
105 1291         7181 $self->{children}[$index];
106             }
107              
108             sub descendant {
109 0     0 0 0 my $self = shift;
110 0         0 my $coord = shift;
111              
112 0         0 my @pos = split /\./, $coord;
113 0         0 my $t = $self;
114 0         0 my $x = shift(@pos); # discard the first empty dot
115 0         0 for (@pos) {
116 0 0 0     0 croak "Error computing descendant: $_ is not a number\n"
117             unless m{\d+} and $_ < $t->children;
118 0         0 $t = $t->child($_);
119             }
120 0         0 return $t;
121             }
122              
123             ####################################################################
124             # Usage : $node->s(@transformationlist);
125             # Example : The following example simplifies arithmetic expressions
126             # using method "s":
127             # > cat Timeszero.trg
128             # /* Operator "and" has higher priority than comma "," */
129             # whatever_times_zero: TIMES(@b, NUM($x) and { $x->{attr} == 0 }) => { $_[0] = $NUM }
130             #
131             # > treereg Timeszero
132             # > cat arrays.pl
133             # !/usr/bin/perl -w
134             # use strict;
135             # use Rule6;
136             # use Parse::Eyapp::Treeregexp;
137             # use Timeszero;
138             #
139             # my $parser = new Rule6();
140             # my $t = $parser->Run;
141             # $t->s(@Timeszero::all);
142             #
143             #
144             # Returns : Nothing
145             # Parameters : The object (is a method) and the list of transformations to apply.
146             # The list may be a list of Parse::Eyapp:YATW objects and/or CODE
147             # references
148             # Throws : No exceptions
149             # Comments : The set of transformations is repeatedly applied to the node
150             # until there are no changes.
151             # The function may hang if the set of transformations
152             # matches forever.
153             # See Also : The "s" method for Parse::Eyapp::YATW objects
154             # (i.e. transformation objects)
155              
156             sub s {
157 24     24 0 455 my @patterns = @_[1..$#_];
158              
159             # Make them Parse::Eyapp:YATW objects if they are CODE references
160 24 100       76 @patterns = map { ref($_) eq 'CODE'?
  41         175  
161             Parse::Eyapp::YATW->new(
162             PATTERN => $_,
163             #PATTERN_ARGS => [],
164             )
165             :
166             $_
167             }
168             @patterns;
169 24         63 my $changes;
170 24         53 do {
171 50         118 $changes = 0;
172 50         115 foreach (@patterns) {
173 87         246 $_->{CHANGES} = 0;
174 87         592 $_->s($_[0]);
175 87         325 $changes += $_->{CHANGES};
176             }
177             } while ($changes);
178             }
179              
180              
181             ####################################################################
182             # Usage : ????
183             # Purpose : bud = Bottom Up Decoration: Decorates the tree with flowers :-)
184             # The purpose is to decorate the AST with attributes during
185             # the context-dependent analysis, mainly type-checking.
186             # Returns : ????
187             # Parameters : The transformations.
188             # Throws : no exceptions
189             # Comments : The tree is traversed bottom-up. The set of
190             # transformations is applied to each node in the order
191             # supplied by the user. As soon as one succeeds
192             # no more transformations are applied.
193             # See Also : n/a
194             # To Do : Avoid closure. Save @patterns inside the object
195             {
196             my @patterns;
197              
198             sub bud {
199 0     0 0 0 @patterns = @_[1..$#_];
200              
201 0 0       0 @patterns = map { ref($_) eq 'CODE'?
  0         0  
202             Parse::Eyapp::YATW->new(
203             PATTERN => $_,
204             #PATTERN_ARGS => [],
205             )
206             :
207             $_
208             }
209             @patterns;
210 0         0 _bud($_[0], undef, undef);
211             }
212              
213             sub _bud {
214 0     0   0 my $node = $_[0];
215 0         0 my $index = $_[2];
216              
217             # Is an odd leaf. Not actually a Parse::Eyapp::Node. Decorate it and leave
218 0 0 0     0 if (!ref($node) or !UNIVERSAL::can($node, "children")) {
219 0         0 for my $p (@patterns) {
220 0 0       0 return if $p->pattern->(
221             $_[0], # Node being visited
222             $_[1], # Father of this node
223             $index, # Index of this node in @Father->children
224             $p, # The YATW pattern object
225             );
226             }
227             };
228              
229             # Recursively decorate subtrees
230 0         0 my $i = 0;
231 0         0 for (@{$node->{children}}) {
  0         0  
232 0         0 $_->_bud($_, $_[0], $i);
233 0         0 $i++;
234             }
235              
236             # Decorate the node
237             #Change YATW object to be the first argument?
238 0         0 for my $p (@patterns) {
239 0 0       0 return if $p->pattern->($_[0], $_[1], $index, $p);
240             }
241             }
242             } # closure for @patterns
243              
244             ####################################################################
245             # Usage :
246             # @t = Parse::Eyapp::Node->new( q{TIMES(NUM(TERMINAL), NUM(TERMINAL))},
247             # sub {
248             # our ($TIMES, @NUM, @TERMINAL);
249             # $TIMES->{type} = "binary operation";
250             # $NUM[0]->{type} = "int";
251             # $NUM[1]->{type} = "float";
252             # $TERMINAL[1]->{attr} = 3.5;
253             # },
254             # );
255             # Purpose : Multi-Constructor
256             # Returns : Array of pointers to the objects created
257             # in scalar context a pointer to the first node
258             # Parameters : The class plus the string description and attribute handler
259              
260             {
261              
262             my %cache;
263              
264             sub m_bless {
265              
266 0     0 0 0 my $key = join "",@_;
267 0         0 my $class = shift;
268 0 0       0 return $cache{$key} if exists $cache{$key};
269              
270 0         0 my $b = bless { children => \@_}, $class;
271 0         0 $cache{$key} = $b;
272              
273 0         0 return $b;
274             }
275             }
276              
277             sub _bless {
278 152     152   260 my $class = shift;
279              
280 152         537 my $b = bless { children => \@_ }, $class;
281 152         322 return $b;
282             }
283              
284             sub hexpand {
285 0     0 0 0 my $class = CORE::shift;
286              
287 0 0       0 my $handler = CORE::pop if ref($_[-1]) eq 'CODE';
288 0         0 my $n = m_bless(@_);
289              
290 0         0 my $newnodeclass = CORE::shift;
291              
292 64     64   505 no strict 'refs';
  64         146  
  64         33554  
293 0 0       0 push @{$newnodeclass."::ISA"}, 'Parse::Eyapp::Node' unless $newnodeclass->isa('Parse::Eyapp::Node');
  0         0  
294              
295 0 0 0     0 if (defined($handler) and UNIVERSAL::isa($handler, "CODE")) {
296 0         0 $handler->($n);
297             }
298              
299 0         0 $n;
300             }
301              
302             sub hnew {
303 0     0 0 0 my $blesser = \&m_bless;
304              
305 0         0 return _new($blesser, @_);
306             }
307              
308             # Regexp for a full Perl identifier
309             sub _new {
310 61     61   110 my $blesser = CORE::shift;
311 61         118 my $class = CORE::shift;
312 61         106 local $_ = CORE::shift; # string: tree description
313 61 100       317 my $handler = CORE::shift if ref($_[0]) eq 'CODE';
314              
315              
316 61         173 my %classes;
317             my $b;
318             #TODO: Shall I receive a prefix?
319              
320 61         0 my (@stack, @index, @results, %results, @place, $open);
321             #skip white spaces
322 61         163 s{\A\s+}{};
323 61         167 while ($_) {
324             # If is a leaf is followed by parenthesis or comma or an ID
325             s{\A([A-Za-z_][A-Za-z0-9_:]*)\s*([),])}
326             {$1()$2} # ... then add an empty pair of parenthesis
327 551 100       1746 and do {
328 51         126 next;
329             };
330              
331             # If is a leaf is followed by an ID
332             s{\A([A-Za-z_][A-Za-z0-9_:]*)\s+([A-Za-z_])}
333             {$1()$2} # ... then add an empty pair of parenthesis
334 500 50       1123 and do {
335 0         0 next;
336             };
337              
338             # If is a leaf at the end
339             s{\A([A-Za-z_][A-Za-z0-9_:]*)\s*$}
340             {$1()} # ... then add an empty pair of parenthesis
341 500 100       1283 and do {
342 18         47 $classes{$1} = 1;
343 18         45 next;
344             };
345              
346             # Is an identifier
347             s{\A([A-Za-z_][A-Za-z0-9_:]*)}{}
348 482 100       1247 and do {
349 152         328 $classes{$1} = 1;
350 152         318 CORE::push @stack, $1;
351 152         339 next;
352             };
353              
354             # Open parenthesis: mark the position for when parenthesis closes
355             s{\A[(]}{}
356 330 100       873 and do {
357 152         244 my $pos = scalar(@stack);
358 152         263 CORE::push @index, $pos;
359 152         441 $place[$pos] = $open++;
360              
361             # Warning! I don't know what I am doing
362 152         336 next;
363             };
364              
365             # Skip commas
366 178 100       411 s{\A,}{} and next;
367              
368             # Closing parenthesis: time to build a node
369 163 100       488 s{\A[)]}{} and do {
370 152 50       402 croak "Syntax error! Closing parenthesis has no left partner!" unless @index;
371 152         261 my $begin = pop @index; # check if empty!
372 152         309 my @children = splice(@stack, $begin);
373 152         500 my $class = pop @stack;
374 152 50 33     803 croak "Syntax error! Any couple of parenthesis must be preceded by an identifier"
375             unless (defined($class) and $class =~ m{^[a-zA-Z_][\w:]*$});
376              
377 152         346 $b = $blesser->($class, @children);
378              
379 152         243 CORE::push @stack, $b;
380 152         268 $results[$place[$begin]] = $b;
381 152         225 CORE::push @{$results{$class}}, $b;
  152         313  
382 152         394 next;
383             };
384              
385 11 50       26 last unless $_;
386              
387             #skip white spaces
388 11 50       42 croak "Error building Parse::Eyapp::Node tree at '$_'." unless s{\A\s+}{};
389             } # while
390 61 50       142 croak "Syntax error! Open parenthesis has no right partner!" if @index;
391             {
392 64     64   466 no strict 'refs';
  64         137  
  64         131913  
  61         96  
393 61         539 for (keys(%classes)) {
394 144 100       605 push @{$_."::ISA"}, 'Parse::Eyapp::Node' unless $_->isa('Parse::Eyapp::Node');
  16         153  
395             }
396             }
397 61 100 66     231 if (defined($handler) and UNIVERSAL::isa($handler, "CODE")) {
398 10         126 $handler->(@results);
399             }
400 61 100       603 return wantarray? @results : $b;
401             }
402              
403             sub new {
404 61     61 0 12174 my $blesser = \&_bless;
405              
406 61         160 _new($blesser, @_);
407             }
408              
409             ## Used by _subtree_list
410             #sub compute_hierarchy {
411             # my @results = @{shift()};
412             #
413             # # Compute the hierarchy
414             # my $b;
415             # my @r = @results;
416             # while (@results) {
417             # $b = pop @results;
418             # my $d = $b->{depth};
419             # my $f = lastval { $_->{depth} < $d} @results;
420             #
421             # $b->{father} = $f;
422             # $b->{children} = [];
423             # unshift @{$f->{children}}, $b;
424             # }
425             # $_->{father} = undef for @results;
426             # bless $_, "Parse::Eyapp::Node::Match" for @r;
427             # return @r;
428             #}
429              
430             # Matches
431              
432             sub m {
433 3     3 0 25 my $self = shift;
434 3 50       13 my @patterns = @_ or croak "Expected a pattern!";
435             croak "Error in method m of Parse::Eyapp::Node. Expected Parse::Eyapp:YATW patterns"
436 3 50   3   17 unless $a = first { !UNIVERSAL::isa($_, "Parse::Eyapp:YATW") } @_;
  3         25  
437              
438             # array context: return all matches
439 3         12 local $a = 0;
440 3         7 my %index = map { ("$_", $a++) } @patterns;
  9         44  
441 3         17 my @stack = (
442             Parse::Eyapp::Node::Match->new(
443             node => $self,
444             depth => 0,
445             dewey => "",
446             patterns =>[]
447             )
448             );
449 3         8 my @results;
450 3         5 do {
451 27         63 my $mn = CORE::shift(@stack);
452 27         134 my %n = %$mn;
453              
454             # See what patterns do match the current $node
455 27         72 for my $pattern (@patterns) {
456 81 100       1519 push @{$mn->{patterns}}, $index{$pattern} if $pattern->{PATTERN}($n{node});
  16         148  
457             }
458 27         251 my $dewey = $n{dewey};
459 27 100       48 if (@{$mn->{patterns}}) {
  27         76  
460 7         19 $mn->{family} = \@patterns;
461              
462             # Is at this time that I have to compute the father
463 7     5   40 my $f = lastval { $dewey =~ m{^$_->{dewey}}} @results;
  5         51  
464 7         29 $mn->{father} = $f;
465             # ... and children
466 7 100       19 push @{$f->{children}}, $mn if defined($f);
  4         10  
467 7         16 CORE::push @results, $mn;
468             }
469 27         61 my $childdepth = $n{depth}+1;
470 27         46 my $k = -1;
471             CORE::unshift @stack,
472             map
473             {
474 24         43 $k++;
475 24         99 Parse::Eyapp::Node::Match->new(
476             node => $_,
477             depth => $childdepth,
478             dewey => "$dewey.$k",
479             patterns => []
480             )
481 27         94 } $n{node}->children();
482             } while (@stack);
483              
484 3 50       130 wantarray? @results : $results[0];
485             }
486              
487             #sub _subtree_scalar {
488             # # scalar context: return iterator
489             # my $self = CORE::shift;
490             # my @patterns = @_ or croak "Expected a pattern!";
491             #
492             # # %index gives the index of $p in @patterns
493             # local $a = 0;
494             # my %index = map { ("$_", $a++) } @patterns;
495             #
496             # my @stack = ();
497             # my $mn = { node => $self, depth => 0, patterns =>[] };
498             # my @results = ();
499             #
500             # return sub {
501             # do {
502             # # See if current $node matches some patterns
503             # my $d = $mn->{depth};
504             # my $childdepth = $d+1;
505             # # See what patterns do match the current $node
506             # for my $pattern (@patterns) {
507             # push @{$mn->{patterns}}, $index{$pattern} if $pattern->{PATTERN}($mn->{node});
508             # }
509             #
510             # if (@{$mn->{patterns}}) { # matched
511             # CORE::push @results, $mn;
512             #
513             # # Compute the hierarchy
514             # my $f = lastval { $_->{depth} < $d} @results;
515             # $mn->{father} = $f;
516             # $mn->{children} = [];
517             # $mn->{family} = \@patterns;
518             # unshift @{$f->{children}}, $mn if defined($f);
519             # bless $mn, "Parse::Eyapp::Node::Match";
520             #
521             # # push children in the stack
522             # CORE::unshift @stack,
523             # map { { node => $_, depth => $childdepth, patterns => [] } }
524             # $mn->{node}->children();
525             # $mn = CORE::shift(@stack);
526             # return $results[-1];
527             # }
528             # # didn't match: push children in the stack
529             # CORE::unshift @stack,
530             # map { { node => $_, depth => $childdepth, patterns => [] } }
531             # $mn->{node}->children();
532             # $mn = CORE::shift(@stack);
533             # } while ($mn); # May be the stack is empty now, but if $mn then there is a node to process
534             # # reset iterator
535             # my @stack = ();
536             # my $mn = { node => $self, depth => 0, patterns =>[] };
537             # return undef;
538             # };
539             #}
540              
541             # Factorize this!!!!!!!!!!!!!!
542             #sub m {
543             # goto &_subtree_list if (wantarray());
544             # goto &_subtree_scalar;
545             #}
546              
547             ####################################################################
548             # Usage : $BLOCK->delete($ASSIGN)
549             # $BLOCK->delete(2)
550             # Purpose : deletes the specified child of the node
551             # Returns : The deleted child
552             # Parameters : The object plus the index or pointer to the child to be deleted
553             # Throws : If the object can't do children or has no children
554             # See Also : n/a
555              
556             sub delete {
557 3     3 0 59 my $self = CORE::shift; # The tree object
558 3         8 my $child = CORE::shift; # index or pointer
559              
560 3 50 33     30 croak "Parse::Eyapp::Node::delete error, node:\n"
561             .Parse::Eyapp::Node::str($self)."\ndoes not have children"
562             unless UNIVERSAL::can($self, 'children') and ($self->children()>0);
563 3 50       43 if (ref($child)) {
564 3         11 my $i = 0;
565 3         13 for ($self->children()) {
566 6 100       25 last if $_ == $child;
567 3         7 $i++;
568             }
569 3 50       13 if ($i == $self->children()) {
570 0         0 warn "Parse::Eyapp::Node::delete warning: node:\n".Parse::Eyapp::Node::str($self)
571             ."\ndoes not have a child like:\n"
572             .Parse::Eyapp::Node::str($child)
573             ."\nThe node was not deleted!\n";
574 0         0 return $child;
575             }
576 3         10 splice(@{$self->{children}}, $i, 1);
  3         11  
577 3         129 return $child;
578             }
579 0         0 my $numchildren = $self->children();
580 0 0 0     0 croak "Parse::Eyapp::Node::delete error: expected an index between 0 and ".
581             ($numchildren-1).". Got $child" unless ($child =~ /\d+/ and $child < $numchildren);
582 0         0 splice(@{$self->{children}}, $child, 1);
  0         0  
583 0         0 return $child;
584             }
585              
586             ####################################################################
587             # Usage : $BLOCK->shift
588             # Purpose : deletes the first child of the node
589             # Returns : The deleted child
590             # Parameters : The object
591             # Throws : If the object can't do children
592             # See Also : n/a
593              
594             sub shift {
595 0     0 0 0 my $self = CORE::shift; # The tree object
596              
597 0 0       0 croak "Parse::Eyapp::Node::shift error, node:\n"
598             .Parse::Eyapp::Node->str($self)."\ndoes not have children"
599             unless UNIVERSAL::can($self, 'children');
600              
601 0         0 return CORE::shift(@{$self->{children}});
  0         0  
602             }
603              
604             sub unshift {
605 0     0 0 0 my $self = CORE::shift; # The tree object
606 0         0 my $node = CORE::shift; # node to insert
607              
608 0         0 CORE::unshift @{$self->{children}}, $node;
  0         0  
609             }
610              
611             sub push {
612 0     0 0 0 my $self = CORE::shift; # The tree object
613             #my $node = CORE::shift; # node to insert
614              
615             #CORE::push @{$self->{children}}, $node;
616 0         0 CORE::push @{$self->{children}}, @_;
  0         0  
617             }
618              
619             sub insert_before {
620 2     2 0 29 my $self = CORE::shift; # The tree object
621 2         7 my $child = CORE::shift; # index or pointer
622 2         5 my $node = CORE::shift; # node to insert
623              
624 2 50 33     20 croak "Parse::Eyapp::Node::insert_before error, node:\n"
625             .Parse::Eyapp::Node::str($self)."\ndoes not have children"
626             unless UNIVERSAL::can($self, 'children') and ($self->children()>0);
627              
628 2 50       13 if (ref($child)) {
629 2         140 my $i = 0;
630 2         12 for ($self->children()) {
631 6 100       16 last if $_ == $child;
632 4         9 $i++;
633             }
634 2 50       7 if ($i == $self->children()) {
635 0         0 warn "Parse::Eyapp::Node::insert_before warning: node:\n"
636             .Parse::Eyapp::Node::str($self)
637             ."\ndoes not have a child like:\n"
638             .Parse::Eyapp::Node::str($child)."\nThe node was not inserted!\n";
639 0         0 return $child;
640             }
641 2         5 splice(@{$self->{children}}, $i, 0, $node);
  2         8  
642 2         13 return $node;
643             }
644 0         0 my $numchildren = $self->children();
645 0 0 0     0 croak "Parse::Eyapp::Node::insert_before error: expected an index between 0 and ".
646             ($numchildren-1).". Got $child" unless ($child =~ /\d+/ and $child < $numchildren);
647 0         0 splice(@{$self->{children}}, $child, 0, $node);
  0         0  
648 0         0 return $child;
649             }
650              
651             sub insert_after {
652 0     0 0 0 my $self = CORE::shift; # The tree object
653 0         0 my $child = CORE::shift; # index or pointer
654 0         0 my $node = CORE::shift; # node to insert
655              
656 0 0 0     0 croak "Parse::Eyapp::Node::insert_after error, node:\n"
657             .Parse::Eyapp::Node::str($self)."\ndoes not have children"
658             unless UNIVERSAL::can($self, 'children') and ($self->children()>0);
659              
660 0 0       0 if (ref($child)) {
661 0         0 my $i = 0;
662 0         0 for ($self->children()) {
663 0 0       0 last if $_ == $child;
664 0         0 $i++;
665             }
666 0 0       0 if ($i == $self->children()) {
667 0         0 warn "Parse::Eyapp::Node::insert_after warning: node:\n"
668             .Parse::Eyapp::Node::str($self).
669             "\ndoes not have a child like:\n"
670             .Parse::Eyapp::Node::str($child)."\nThe node was not inserted!\n";
671 0         0 return $child;
672             }
673 0         0 splice(@{$self->{children}}, $i+1, 0, $node);
  0         0  
674 0         0 return $node;
675             }
676 0         0 my $numchildren = $self->children();
677 0 0 0     0 croak "Parse::Eyapp::Node::insert_after error: expected an index between 0 and ".
678             ($numchildren-1).". Got $child" unless ($child =~ /\d+/ and $child < $numchildren);
679 0         0 splice(@{$self->{children}}, $child+1, 0, $node);
  0         0  
680 0         0 return $child;
681             }
682              
683             { # $match closure
684              
685             my $match;
686              
687             sub clean_tree {
688 1     1 0 11 $match = pop;
689 1 50 33     9 croak "clean tree: a node and code reference expected" unless (ref($match) eq 'CODE') and (@_ > 0);
690 1         5 $_[0]->_clean_tree();
691             }
692              
693             sub _clean_tree {
694 6     6   11 my @children;
695            
696 6         21 for ($_[0]->children()) {
697 16 100 66     94 next if (!defined($_) or $match->($_));
698            
699 5         61 $_->_clean_tree();
700 5         23 CORE::push @children, $_;
701             }
702 6         36 $_[0]->{children} = \@children; # Bad code
703             }
704             } # $match closure
705              
706             ####################################################################
707             # Usage : $t->str
708             # Returns : Returns a string describing the Parse::Eyapp::Node as a term
709             # i.e., s.t. like: 'PROGRAM(FUNCTION(RETURN(TERMINAL,VAR(TERMINAL))))'
710             our @PREFIXES = qw(Parse::Eyapp::Node::);
711             our $INDENT = 0; # -1 new 0 = compact, 1 = indent, 2 = indent and include Types in closing parenthesis
712             our $STRSEP = ',';
713             our $DELIMITER = '[';
714             our $FOOTNOTE_HEADER = "\n---------------------------\n";
715             our $FOOTNOTE_SEP = ")\n";
716             our $FOOTNOTE_LEFT = '^{';
717             our $FOOTNOTE_RIGHT = '}';
718             our $LINESEP = 4;
719             our $CLASS_HANDLER = sub { type($_[0]) }; # What to print to identify the node
720              
721             my %match_del = (
722             '[' => ']',
723             '{' => '}',
724             '(' => ')',
725             '<' => '>'
726             );
727              
728             my $pair;
729             my $footnotes = '';
730             my $footnote_label;
731              
732             sub str {
733              
734 9     9 0 79 my @terms;
735              
736             # Consume arg only if called as a class method Parse::Eyap::Node->str($node1, $node2, ...)
737 9 50       35 CORE::shift unless ref($_[0]);
738              
739 9         116 for (@_) {
740 9         27 $footnote_label = 0;
741 9         19 $footnotes = '';
742             # Set delimiters for semantic values
743 9 50 33     60 if (defined($DELIMITER) and exists($match_del{$DELIMITER})) {
744 9         24 $pair = $match_del{$DELIMITER};
745             }
746             else {
747 0         0 $DELIMITER = $pair = '';
748             }
749 9         38 CORE::push @terms, _str($_).$footnotes;
750             }
751 9 50       88 return wantarray? @terms : $terms[0];
752             }
753              
754             sub _str {
755 98     98   139 my $self = CORE::shift; # root of the subtree
756 98   100     226 my $indent = (CORE::shift or 0); # current depth in spaces " "
757              
758 98         179 my @children = Parse::Eyapp::Node::children($self);
759 98         168 my @t;
760              
761             my $res;
762 98         147 my $fn = $footnote_label;
763 98 50 33     438 if ($INDENT >= 0 && UNIVERSAL::can($self, 'footnote')) {
764 0         0 $res = $self->footnote;
765 0 0       0 $footnotes .= $FOOTNOTE_HEADER.$footnote_label++.$FOOTNOTE_SEP.$res if $res;
766             }
767              
768             # recursively visit nodes
769 98         177 for (@children) {
770 89 50       268 CORE::push @t, Parse::Eyapp::Node::_str($_, $indent+2) if defined($_);
771             }
772 98         161 local $" = $STRSEP;
773 98         192 my $class = $CLASS_HANDLER->($self);
774 98         321 $class =~ s/^$_// for @PREFIXES;
775 98         160 my $information;
776 98 100 66     519 $information = $self->info if ($INDENT >= 0 && UNIVERSAL::can($self, 'info'));
777 98 100       464 $class .= $DELIMITER.$information.$pair if defined($information);
778 98 50 33     344 if ($INDENT >= 0 && $res) {
779 0         0 $class .= $FOOTNOTE_LEFT.$fn.$FOOTNOTE_RIGHT;
780             }
781              
782 98 50       268 if ($INDENT > 0) {
783 0         0 my $w = " "x$indent;
784 0         0 $class = "\n$w$class";
785 0 0       0 $class .= "(@t\n$w)" if @children;
786 0 0 0     0 $class .= " # ".$CLASS_HANDLER->($self) if ($INDENT > 1) and ($class =~ tr/\n/\n/>$LINESEP);
787             }
788             else {
789 98 100       297 $class .= "(@t)" if @children;
790             }
791 98         271 return $class;
792             }
793              
794             sub _dot {
795 0     0   0 my ($root, $number) = @_;
796              
797 0         0 my $type = $root->type();
798              
799 0         0 my $information;
800 0 0 0     0 $information = $root->info if ($INDENT >= 0 && $root->can('info'));
801 0         0 my $class = $CLASS_HANDLER->($root);
802 0 0       0 $class = qq{$class$DELIMITER$information$pair} if defined($information);
803              
804 0         0 my $dot = qq{ $number [label = <$class>];\n};
805              
806 0         0 my $k = 0;
807 0         0 my @dots = map { $k++; $_->_dot("$number$k") } $root->children;
  0         0  
  0         0  
808              
809 0         0 for($k = 1; $k <= $root->children; $k++) {;
810 0         0 $dot .= qq{ $number -> $number$k;\n};
811             }
812              
813 0         0 return $dot.join('',@dots);
814             }
815              
816             sub dot {
817 0     0 0 0 my $dot = $_[0]->_dot('0');
818 0         0 return << "EOGRAPH";
819             digraph G {
820             ordering=out
821              
822             $dot
823             }
824             EOGRAPH
825             }
826              
827             sub fdot {
828 0     0 0 0 my ($self, $file) = @_;
829              
830 0 0       0 if ($file) {
831 0 0       0 $file .= '.dot' unless $file =~ /\.dot$/;
832             }
833             else {
834 0         0 $file = $self->type().".dot";
835             }
836 0         0 open my $f, "> $file";
837 0         0 print $f $self->dot();
838 0         0 close($f);
839             }
840              
841             BEGIN {
842 64     64   548 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};
843              
844 64         2050 for my $format (@dotFormats) {
845            
846 64     64   560 no strict 'refs';
  64         151  
  64         7744  
847 2752         58347 *{'Parse::Eyapp::Node::'.$format} = sub {
848 0     0   0 my ($self, $file) = @_;
849            
850 0 0       0 $file = $self->type() unless defined($file);
851            
852 0         0 $self->fdot($file);
853            
854 0         0 $file =~ s/\.(dot|$format)$//;
855 0         0 my $dotfile = "$file.dot";
856 0         0 my $pngfile = "$file.$format";
857 0         0 my $err = qx{dot -T$format $dotfile -o $pngfile 2>&1};
858 0         0 return ($err, $?);
859             }
860 2752         9253 }
861             }
862              
863             sub translation_scheme {
864 258     258 0 604 my $self = CORE::shift; # root of the subtree
865 258         575 my @children = $self->children();
866 258         491 for (@children) {
867 371 100       1478 if (ref($_) eq 'CODE') {
    50          
868 126         361 $_->($self, $self->Children);
869             }
870             elsif (defined($_)) {
871 245         524 translation_scheme($_);
872             }
873             }
874             }
875              
876             sub type {
877 219     219 0 1185 my $type = ref($_[0]);
878              
879 219 50       478 if ($type) {
880 219 100       469 if (defined($_[1])) {
881 88         160 $type = $_[1];
882 88         283 Parse::Eyapp::Driver::BeANode($type);
883 88         167 bless $_[0], $type;
884             }
885 219         557 return $type
886             }
887 0         0 return 'Parse::Eyapp::Node::STRING';
888             }
889              
890             { # Tree "fuzzy" equality
891              
892             ####################################################################
893             # Usage : $t1->equal($t2, n => sub { return $_[0] == $_[1] })
894             # Purpose : Checks the equality between two AST
895             # Returns : 1 if equal, 0 if not 'equal'
896             # Parameters : Two Parse::Eyapp:Node nodes and a hash of comparison handlers.
897             # The keys of the hash are the attributes of the nodes. The value is
898             # a comparator function. The comparator for key $k receives the attribute
899             # for the nodes being visited and rmust return true if they are considered similar
900             # Throws : exceptions if the parameters aren't Parse::Eyapp::Nodes
901              
902             my %handler;
903              
904             # True if the two trees look similar
905             sub equal {
906 2 50   2 0 11 croak "Parse::Eyapp::Node::equal error. Expected two syntax trees \n" unless (@_ > 1);
907              
908 2         6 %handler = splice(@_, 2);
909 2         8 my $key = '';
910 2 50   1   9 defined($key=firstval {!UNIVERSAL::isa($handler{$_},'CODE') } keys %handler)
  1         5  
911             and
912             croak "Parse::Eyapp::Node::equal error. Expected a CODE ref for attribute $key\n";
913 2         10 goto &_equal;
914             }
915              
916             sub _equal {
917 4     4   5 my $tree1 = CORE::shift;
918 4         7 my $tree2 = CORE::shift;
919              
920             # Same type
921 4 50       9 return 0 unless ref($tree1) eq ref($tree2);
922              
923             # Check attributes via handlers
924 4         9 for (keys %handler) {
925             # Check for existence
926 1 50 33     8 return 0 if (exists($tree1->{$_}) && !exists($tree2->{$_}));
927 0 0 0     0 return 0 if (exists($tree2->{$_}) && !exists($tree1->{$_}));
928              
929             # Check for definition
930 0 0 0     0 return 0 if (defined($tree1->{$_}) && !defined($tree2->{$_}));
931 0 0 0     0 return 0 if (defined($tree2->{$_}) && !defined($tree1->{$_}));
932              
933             # Check for equality
934 0 0       0 return 0 unless $handler{$_}->($tree1->{$_}, $tree2->{$_});
935             }
936              
937             # Same number of children
938 3         3 my @children1 = @{$tree1->{children}};
  3         7  
939 3         3 my @children2 = @{$tree2->{children}};
  3         5  
940 3 50       7 return 0 unless @children1 == @children2;
941              
942             # Children must be similar
943 3         5 for (@children1) {
944 2         4 my $ch2 = CORE::shift @children2;
945 2 50       5 return 0 unless _equal($_, $ch2);
946             }
947 3         11 return 1;
948             }
949             }
950              
951             1;
952              
953             package Parse::Eyapp::Node::Match;
954             our @ISA = qw(Parse::Eyapp::Node);
955              
956             # A Parse::Eyapp::Node::Match object is a reference
957             # to a tree of Parse::Eyapp::Nodes that has been used
958             # in a tree matching regexp. You can think of them
959             # as the equivalent of $1 $2, ... in treeregexeps
960              
961             # The depth of the Parse::Eyapp::Node being referenced
962              
963             sub new {
964 125     125   233 my $class = shift;
965              
966 125         377 my $matchnode = { @_ };
967 125         256 $matchnode->{children} = [];
968 125         403 bless $matchnode, $class;
969             }
970              
971             sub depth {
972 0     0   0 my $self = shift;
973              
974 0         0 return $self->{depth};
975             }
976              
977             # The coordinates of the Parse::Eyapp::Node being referenced
978             sub coord {
979 0     0   0 my $self = shift;
980              
981 0         0 return $self->{dewey};
982             }
983              
984              
985             # The Parse::Eyapp::Node being referenced
986             sub node {
987 31     31   48 my $self = shift;
988              
989 31         82 return $self->{node};
990             }
991              
992             # The Parse::Eyapp::Node:Match that references
993             # the nearest ancestor of $self->{node} that matched
994             sub father {
995 31     31   129 my $self = shift;
996              
997 31         87 return $self->{father};
998             }
999            
1000             # The patterns that matched with $self->{node}
1001             # Indexes
1002             sub patterns {
1003 0     0     my $self = shift;
1004              
1005 0 0         @{$self->{patterns}} = @_ if @_;
  0            
1006 0           return @{$self->{patterns}};
  0            
1007             }
1008            
1009             # The original list of patterns that produced this match
1010             sub family {
1011 0     0     my $self = shift;
1012              
1013 0 0         @{$self->{family}} = @_ if @_;
  0            
1014 0           return @{$self->{family}};
  0            
1015             }
1016            
1017             # The names of the patterns that matched
1018             sub names {
1019 0     0     my $self = shift;
1020              
1021 0           my @indexes = $self->patterns;
1022 0           my @family = $self->family;
1023              
1024 0 0         return map { $_->{NAME} or "Unknown" } @family[@indexes];
  0            
1025             }
1026            
1027             sub info {
1028 0     0     my $self = shift;
1029              
1030 0           my $node = $self->node;
1031 0           my @names = $self->names;
1032 0           my $nodeinfo;
1033 0 0         if (UNIVERSAL::can($node, 'info')) {
1034 0           $nodeinfo = ":".$node->info;
1035             }
1036             else {
1037 0           $nodeinfo = "";
1038             }
1039 0           return "[".ref($self->node).":".$self->depth.":@names$nodeinfo]"
1040             }
1041              
1042             1;
1043              
1044