File Coverage

blib/lib/Parse/Eyapp/YATW.pm
Criterion Covered Total %
statement 132 141 93.6
branch 27 40 67.5
condition 5 6 83.3
subroutine 21 23 91.3
pod 0 15 0.0
total 185 225 82.2


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::YATW;
9 64     64   379 use strict;
  64         149  
  64         1542  
10 64     64   323 use warnings;
  64         122  
  64         1563  
11 64     64   293 use Carp;
  64         119  
  64         2739  
12 64     64   24420 use Data::Dumper;
  64         245810  
  64         3626  
13 64     64   493 use List::Util qw(first);
  64         142  
  64         77237  
14              
15             sub firstval(&@) {
16 0     0 0 0 my $handler = shift;
17            
18 0         0 return (grep { $handler->($_) } @_)[0]
  0         0  
19             }
20              
21             sub lastval(&@) {
22 40     40 0 69 my $handler = shift;
23            
24 40         88 return (grep { $handler->($_) } @_)[-1]
  147         291  
25             }
26              
27             sub valid_keys {
28 64     64 0 223 my %valid_args = @_;
29              
30 64         225 my @valid_args = keys(%valid_args);
31 64         160 local $" = ", ";
32 64         312 return "@valid_args"
33             }
34              
35             sub invalid_keys {
36 63     63 0 119 my $valid_args = shift;
37 63         133 my $args = shift;
38              
39 63     122   475 return (first { !exists($valid_args->{$_}) } keys(%$args));
  122         404  
40             }
41              
42              
43             our $VERSION = $Parse::Eyapp::Driver::VERSION;
44              
45             our $FILENAME=__FILE__;
46              
47             # TODO: Check args. Typical args:
48             # 'CHANGES' => 0,
49             # 'PATTERN' => sub { "DUMMY" },
50             # 'NAME' => 'fold',
51             # 'PATTERN_ARGS' => [],
52             # 'PENDING_TASKS' => {},
53             # 'NODE' => []
54              
55             my %_new_yatw = (
56             PATTERN => 'CODE',
57             NAME => 'STRING',
58             );
59              
60             my $validkeys = valid_keys(%_new_yatw);
61              
62             sub new {
63 63     63 0 161 my $class = shift;
64 63         258 my %args = @_;
65              
66 63 50       272 croak "Error. Expected a code reference when building a tree walker. " unless (ref($args{PATTERN}) eq 'CODE');
67 63 50       234 if (defined($a = invalid_keys(\%_new_yatw, \%args))) {
68 0         0 croak("Parse::Eyapp::YATW::new Error!: unknown argument $a. Valid arguments are: $validkeys")
69             }
70              
71              
72             # obsolete, I have to delete this
73             #$args{PATTERN_ARGS} = [] unless (ref($args{PATTERN_ARGS}) eq 'ARRAY');
74              
75             # Internal fields
76              
77             # Tell us if the node has changed after the visit
78 63         246 $args{CHANGES} = 0;
79            
80             # PENDING_TASKS is a queue storing the tasks waiting for a "safe time/node" to do them
81             # Usually that time occurs when visiting the father of the node who generated the job
82             # (when asap criteria is applied).
83             # Keys are node references. Values are array references. Each entry defines:
84             # [ the task kind, the node where to do the job, and info related to the particular job ]
85             # Example: @{$self->{PENDING_TASKS}{$father}}, ['insert_before', $node, ${$self->{NODE}}[0] ];
86 63         160 $args{PENDING_TASKS} = {};
87              
88             # NODE is a stack storing the ancestor of the node being visited
89             # Example: my $ancestor = ${$self->{NODE}}[$k]; when k=1 is the father, k=2 the grandfather, etc.
90             # Example: CORE::unshift @{$self->{NODE}}, $_[0]; Finished the visit so take it out
91 63         149 $args{NODE} = [];
92              
93 63         312 bless \%args, $class;
94             }
95              
96             sub buildpatterns {
97 30     30 0 122 my $class = shift;
98            
99 30         66 my @family;
100 30         195 while (my ($n, $p) = splice(@_, 0,2)) {
101 59         238 push @family, Parse::Eyapp::YATW->new(NAME => $n, PATTERN => $p);
102             }
103 30 50       261 return wantarray? @family : $family[0];
104             }
105              
106             ####################################################################
107             # Usage : @r = $b{$_}->m($t)
108             # See Simple4.eyp and m_yatw.pl in the examples directory
109             # Returns : Returns an array of nodes matching the treeregexp
110             # The set of nodes is a Parse::Eyapp::Node::Match tree
111             # showing the relation between the matches
112             # Parameters : The tree (and the object of course)
113             # depth is no longer used: eliminate
114             sub m {
115 9     9 0 23 my $p = shift(); # pattern YATW object
116 9         16 my $t = shift; # tree
117 9         32 my $pattern = $p->{PATTERN}; # CODE ref
118              
119             # References to the found nodes are stored in @stack
120 9         60 my @stack = ( Parse::Eyapp::Node::Match->new(node=>$t, depth=>0, dewey => "") );
121 9         20 my @results;
122 9         19 do {
123 98         167 my $n = CORE::shift(@stack);
124 98         351 my %n = %$n;
125              
126 98         209 my $dewey = $n->{dewey};
127 98         138 my $d = $n->{depth};
128 98 100       1851 if ($pattern->($n{node})) {
129 40         94 $n->{family} = [ $p ];
130 40         90 $n->{patterns} = [ 0 ];
131              
132             # Is at this time that I have to compute the father
133 40     147   226 my $f = lastval { $dewey =~ m{^$_->{dewey}}} @results;
  147         936  
134 40         142 $n->{father} = $f;
135             # ... and children
136 40 100       108 push @{$f->{children}}, $n if defined($f);
  31         75  
137 40         74 push @results, $n;
138             }
139 98         163 my $k = 0;
140             CORE::unshift @stack,
141             map {
142 89         133 local $a;
143 89         296 $a = Parse::Eyapp::Node::Match->new(node=>$_, depth=>$d+1, dewey=>"$dewey.$k" );
144 89         140 $k++;
145 89         348 $a;
146 98         264 } $n{node}->children();
147             } while (@stack);
148              
149 9 50       54 return wantarray? @results : $results[0];
150             }
151              
152             ######################### getter-setter for YATW objects ###########################
153              
154             sub pattern {
155 989     989 0 1460 my $self = shift;
156 989 50       2088 $self->{PATTERN} = shift if (@_);
157 989         13105 return $self->{PATTERN};
158             }
159              
160             sub name {
161 0     0 0 0 my $self = shift;
162 0 0       0 $self->{NAME} = shift if (@_);
163 0         0 return $self->{NAME};
164             }
165              
166             #sub pattern_args {
167             # my $self = shift;
168             #
169             # $self->{PATTERN_ARGS} = @_ if @_;
170             # return @{$self->{PATTERN_ARGS}};
171             #}
172              
173             ########################## PENDING TASKS management ################################
174              
175             # Purpose : Deletes the node that matched from the list of children of its father.
176             sub delete {
177 36     36 0 196 my $self = shift;
178              
179 36         127 bless $self->{NODE}[0], 'Parse::Eyapp::Node::DELETE';
180             }
181            
182             sub make_delete_effective {
183 841     841 0 1254 my $self = shift;
184 841         1283 my $node = shift;
185              
186 841         2160 my $i = -1+$node->children;
187 841         2111 while ($i >= 0) {
188 876 100       2475 if (UNIVERSAL::isa($node->child($i), 'Parse::Eyapp::Node::DELETE')) {
189 36 50       60 $self->{CHANGES}++ if defined(splice(@{$node->{children}}, $i, 1));
  36         109  
190             }
191 876         2119 $i--;
192             }
193             }
194              
195             ####################################################################
196             # Usage : my $b = Parse::Eyapp::Node->new( 'NUM(TERMINAL)', sub { $_[1]->{attr} = 4 });
197             # $yatw_pattern->unshift($b);
198             # Parameters : YATW object, node to insert,
199             # ancestor offset: 0 = root of the tree that matched, 1 = father, 2 = granfather, etc.
200              
201             sub unshift {
202 3     3 0 20 my ($self, $node, $k) = @_;
203 3 50       10 $k = 1 unless defined($k); # father by default
204              
205 3         4 my $ancestor = ${$self->{NODE}}[$k];
  3         8  
206 3 50       9 croak "unshift: does not exist ancestor $k of node ".Dumper(${$self->{NODE}}[0]) unless defined($ancestor);
  0         0  
207              
208             # Stringification of $ancestor. Hope it works
209             # operation, node to insert,
210 3         4 push @{$self->{PENDING_TASKS}{$ancestor}}, ['unshift', $node ];
  3         18  
211             }
212              
213             sub insert_before {
214 1     1 0 6 my ($self, $node) = @_;
215              
216 1         1 my $father = ${$self->{NODE}}[1];
  1         3  
217 1 50       3 croak "insert_before: does not exist father of node ".Dumper(${$self->{NODE}}[0]) unless defined($father);
  0         0  
218              
219             # operation, node to insert, before this node
220 1         2 push @{$self->{PENDING_TASKS}{$father}}, ['insert_before', $node, ${$self->{NODE}}[0] ];
  1         5  
  1         6  
221             }
222              
223             sub _delayed_insert_before {
224 1     1   3 my ($father, $node, $before) = @_;
225              
226 1         2 my $i = 0;
227 1         3 for ($father->children()) {
228 3 100       109 last if ($_ == $before);
229 2         9 $i++;
230             }
231 1         4 splice @{$father->{children}}, $i, 0, $node;
  1         6  
232             }
233              
234             sub do_pending_tasks {
235 841     841 0 1266 my $self = shift;
236 841         1223 my $node = shift;
237              
238 841         1737 my $mytasks = $self->{PENDING_TASKS}{$node};
239 841   100     2573 while ($mytasks and (my $job = shift @{$mytasks})) {
  7         30  
240 4         11 my @args = @$job;
241 4         7 my $task = shift @args;
242              
243             # change this for a jump table
244 4 100       15 if ($task eq 'unshift') {
    50          
245 3         5 CORE::unshift(@{$node->{children}}, @args);
  3         8  
246 3         11 $self->{CHANGES}++;
247             }
248             elsif ($task eq 'insert_before') {
249 1         4 _delayed_insert_before($node, @args);
250 1         7 $self->{CHANGES}++;
251             }
252             }
253             }
254              
255             ####################################################################
256             # Parameters : pattern, node, father of the node, index of the child in the children array
257             # YATW object. Probably too many
258             sub s {
259 989     989 0 1620 my $self = shift;
260 989 50       2408 my $node = $_[0] or croak("Error. Method __PACKAGE__::s requires a node");
261 989         1464 CORE::unshift @{$self->{NODE}}, $_[0];
  989         2013  
262             # father is $_[1]
263 989         1588 my $index = $_[2];
264              
265             # If is not a reference or can't children then simply check the matching and leave
266 989 100 66     5183 if (!ref($node) or !UNIVERSAL::can($node, "children")) {
267            
268 148 100       320 $self->{CHANGES}++ if $self->pattern->(
269             $_[0], # Node being visited
270             $_[1], # Father of this node
271             $index, # Index of this node in @Father->children
272             $self, # The YATW pattern object
273             );
274 148         556 return;
275             };
276            
277             # Else, is not a leaf and is a regular Parse::Eyapp::Node
278             # Recursively transform subtrees
279 841         1417 my $i = 0;
280 841         1252 for (@{$node->{children}}) {
  841         2037  
281 882         2369 $self->s($_, $_[0], $i);
282 882         1770 $i++;
283             }
284            
285 841         1439 my $number_of_changes = $self->{CHANGES};
286             # Now is safe to delete children nodes that are no longer needed
287 841         2356 $self->make_delete_effective($node);
288              
289             # Safely do pending jobs for this node
290 841         2109 $self->do_pending_tasks($node);
291              
292             #node , father, childindex, and ...
293             #Change YATW object to be the first argument?
294 841 100       2036 if ($self->pattern->($_[0], $_[1], $index, $self)) {
295 52         915 $self->{CHANGES}++;
296             }
297 841         3848 shift @{$self->{NODE}};
  841         1747  
298             }
299              
300             1;
301