File Coverage

blib/lib/MarpaX/Languages/C/AST/Util.pm
Criterion Covered Total %
statement 27 126 21.4
branch 2 26 7.6
condition 1 14 7.1
subroutine 8 17 47.0
pod 8 9 88.8
total 46 192 23.9


line stmt bran cond sub pod time code
1 2     2   7 use strict;
  2         4  
  2         393  
2 2     2   6 use warnings FATAL => 'all';
  2         2  
  2         64  
3              
4             package MarpaX::Languages::C::AST::Util;
5              
6             # ABSTRACT: C Translation to AST - Class method utilities
7              
8 2     2   5 use Exporter 'import';
  2         2  
  2         327  
9 2     2   6 use Log::Any qw/$log/;
  2         1  
  2         11  
10 2     2   721 use Data::Dumper;
  2         4831  
  2         96  
11 2     2   7 use Carp qw/croak/;
  2         1  
  2         328  
12             # Marpa follows Unicode recommendation, i.e:
13             #
14             # a LF (line feed U+000A);
15             # a CR (carriage return, U+000D), when it is not followed by a LF;
16             # a CRLF sequence (U+000D,U+000A);
17             # a NEL (next line, U+0085);
18             # a VT (vertical tab, U+000B);
19             # a FF (form feed, U+000C);
20             # a LS (line separator, U+2028) or
21             # a PS (paragraph separator, U+2029)
22             #
23             # BUT is accounting two lines when it sees a CRLF sequence
24             # I left this regexp alone and will change it to
25             # qr/(?>\x{0D}\x{0A}|\x{0D}|\x{0A}|\x{85}|\x{0B}|\x{0C}|\x{2028}|\x{2029})/
26             # when I know which version of Marpa fixes this issue.
27             #
28             # C.f. https://github.com/jeffreykegler/Marpa--R2/issues/217
29             #
30             our $NEWLINE_MARPA_REGEXP = qr/[\x{0D}|\x{0A}|\x{85}|\x{0B}|\x{0C}|\x{2028}|\x{2029}]/;
31             our $NEWLINE_CORRECT_REGEXP = qr/\R/;
32              
33             our $VERSION = '0.47'; # VERSION
34             # CONTRIBUTORS
35              
36             our @EXPORT_OK = qw/whoami whowasi traceAndUnpack logCroak showLineAndCol lineAndCol lastCompleted startAndLength rulesByDepth/;
37             our %EXPORT_TAGS = ('all' => [ @EXPORT_OK ]);
38              
39              
40             sub _cutbase {
41 0     0   0 my ($rc, $base) = @_;
42 2 0 0 2   746 if (defined($base) && "$base" && index($rc, "${base}::") == $[) {
  2   0     513  
  2         1797  
  0         0  
43 0         0 substr($rc, $[, length($base) + 2, '');
44             }
45 0         0 return $rc;
46             }
47              
48             sub whoami {
49 0     0 1 0 return _cutbase((caller(1))[3], @_);
50             }
51              
52              
53             sub whowasi {
54 0     0 1 0 return _cutbase((caller(2))[3], @_);
55             }
56              
57              
58             sub traceAndUnpack {
59 0     0 1 0 my $nameOfArgumentsp = shift;
60              
61 0         0 my $whowasi = whowasi();
62 0         0 my @string = ();
63 0         0 my $min1 = scalar(@{$nameOfArgumentsp});
  0         0  
64 0         0 my $min2 = scalar(@_);
65 0 0       0 my $min = ($min1 < $min2) ? $min1 : $min2;
66 0         0 my $rc = {};
67 0         0 foreach (0..--$min) {
68 0         0 my ($key, $value) = ($nameOfArgumentsp->[$_], $_[$_]);
69 0         0 my $string = Data::Dumper->new([$value], [$key])->Indent(0)->Sortkeys(1)->Quotekeys(0)->Terse(0)->Dump();
70 0         0 $rc->{$key} = $value;
71             #
72             # Remove the ';'
73             #
74 0         0 substr($string, -1, 1, '');
75 0         0 push(@string, $string);
76             }
77             #
78             # Skip MarpaX::Languages::C::AST::if any
79             #
80 0         0 $whowasi =~ s/^MarpaX::Languages::C::AST:://;
81 0         0 $log->tracef('%s(%s)', $whowasi, join(', ', @string));
82 0         0 return($rc);
83             }
84              
85              
86             sub logCroak {
87 0     0 1 0 my ($fmt, @arg) = @_;
88              
89 0         0 my $msg = sprintf($fmt, @arg);
90 0         0 $log->fatalf('%s', $msg);
91 0 0       0 if (! $log->is_fatal()) {
92             #
93             # Logging is not enabled at FATAL level: re do the message in croak
94             #
95 0         0 croak $msg;
96             } else {
97             #
98             # Logging is enabled at FATAL level: no new message
99             #
100 0         0 croak;
101             }
102             }
103              
104              
105             sub showLineAndCol {
106 0     0 1 0 my ($line, $col, $sourcep) = @_;
107              
108 0 0       0 my $pointer = ($col > 0 ? '-' x ($col-1) : '') . '^';
109 0         0 my $content = '';
110              
111 0         0 my $prevpos = pos(${$sourcep});
  0         0  
112 0         0 pos(${$sourcep}) = undef;
  0         0  
113 0         0 my $thisline = 0;
114 0         0 my $nbnewlines = 0;
115 0         0 my $eos = 0;
116 0         0 while (${$sourcep} =~ m/\G(.*?)($NEWLINE_MARPA_REGEXP|\Z)/scmg) {
  0         0  
117 0 0       0 if (++$thisline == $line) {
118 0         0 $content = substr(${$sourcep}, $-[1], $+[1] - $-[1]);
  0         0  
119 0 0       0 $eos = (($+[2] - $-[2]) > 0) ? 0 : 1;
120 0         0 last;
121             }
122             }
123             #
124             # Revisit newlines count (column count fortunately remains unchanged)
125             #
126 0 0       0 if (length($content) > 0) {
127 0         0 $content =~ s/\t/ /g;
128 0         0 $nbnewlines = () = substr(${$sourcep}, 0, pos(${$sourcep})) =~ /$NEWLINE_CORRECT_REGEXP/g;
  0         0  
  0         0  
129 0 0       0 if ($eos) {
130 0         0 ++$nbnewlines; # End of string instead of newline
131             }
132             }
133 0         0 pos(${$sourcep}) = $prevpos;
  0         0  
134             #
135             # We rely on any space being a true space for the pointer accuracy
136             #
137 0         0 $content =~ s/\s/ /g;
138              
139 0         0 return "At line $nbnewlines, column $col\n\n$content\n$pointer";
140             }
141              
142              
143             sub lineAndCol {
144 19     19 1 20 my ($impl, $g1, $start) = @_;
145              
146 19 100       32 if (! defined($start)) {
147 17   33     64 $g1 //= $impl->current_g1_location();
148 17         180 ($start, undef) = $impl->g1_location_to_span($g1);
149             }
150 19         115 my ($line, $column) = $impl->line_column($start);
151 19         119 return [ $line, $column ];
152             }
153              
154              
155             sub startAndLength {
156 0     0 1   my ($impl, $g1) = @_;
157              
158 0   0       $g1 //= $impl->current_g1_location();
159 0           my ($start, $length) = $impl->g1_location_to_span($g1);
160 0           return [ $start, $length ];
161             }
162              
163              
164             sub lastCompleted {
165 0     0 1   my ($impl, $symbol) = @_;
166 0           return $impl->substring($impl->last_completed($symbol));
167             }
168              
169              
170             sub rulesByDepth {
171 0     0 0   my ($impl, $subGrammar) = @_;
172              
173 0   0       $subGrammar ||= 'G1';
174              
175             #
176             # We start by expanding all ruleIds to a LHS symbol id and RHS symbol ids
177             #
178 0           my %ruleIds = ();
179 0           foreach ($impl->rule_ids($subGrammar)) {
180 0           my $ruleId = $_;
181 0           $ruleIds{$ruleId} = [ $impl->rule_expand($ruleId, $subGrammar) ];
182             }
183             #
184             # We ask what is the start symbol
185             #
186 0           my $startSymbolId = $impl->start_symbol_id();
187             #
188             # We search for the start symbol in all the rules
189             #
190 0           my @queue = ();
191 0           my %depth = ();
192 0           foreach (keys %ruleIds) {
193 0           my $ruleId = $_;
194 0 0         if ($ruleIds{$ruleId}->[0] == $startSymbolId) {
195 0           push(@queue, $ruleId);
196 0           $depth{$ruleId} = 0;
197             }
198             }
199              
200 0           while (@queue) {
201 0           my $ruleId = shift(@queue);
202 0           my $newDepth = $depth{$ruleId} + 1;
203             #
204             # Get the RHS ids of this ruleId and select only those that are also LHS
205             #
206 0           my (undef, @rhsIds) = @{$ruleIds{$ruleId}};
  0            
207 0           foreach (@rhsIds) {
208 0           my $lhsId = $_;
209 0           foreach (keys %ruleIds) {
210 0           my $ruleId = $_;
211 0 0         if (! exists($depth{$ruleId})) {
212             #
213             # Rule not already inserted
214             #
215 0 0         if ($ruleIds{$ruleId}->[0] == $lhsId) {
216             #
217             # And having an LHS id equal to one of the RHS ids we dequeued
218             #
219 0           push(@queue, $ruleId);
220 0           $depth{$ruleId} = $newDepth;
221             }
222             }
223             }
224             }
225             }
226              
227 0           my @rc = ();
228 0 0         foreach (sort {($depth{$a} <=> $depth{$b}) || ($a <=> $b)} keys %depth) {
  0            
229 0           my $ruleId = $_;
230 0           my ($lhsId, @rhsIds) = @{$ruleIds{$ruleId}};
  0            
231             push(@rc, {ruleId => $ruleId,
232             ruleName => $impl->rule_name($ruleId),
233             lhsId => $lhsId,
234             lhsName => $impl->symbol_name($lhsId),
235             rhsIds => [ @rhsIds ],
236 0           rhsNames => [ map {$impl->symbol_name($_)} @rhsIds ],
237 0           depth => $depth{$ruleId}});
238             }
239              
240 0           return \@rc;
241             }
242              
243              
244             1;
245              
246             __END__