File Coverage

blib/lib/MarpaX/Languages/ECMAScript/AST.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1 1     1   23375 use strict;
  1         2  
  1         44  
2 1     1   5 use warnings FATAL => 'all';
  1         2  
  1         148  
3              
4             package MarpaX::Languages::ECMAScript::AST;
5              
6             # ABSTRACT: Translate a ECMAScript source to an AST
7              
8 1     1   743 use MarpaX::Languages::ECMAScript::AST::Grammar qw//;
  1         5  
  1         28  
9 1     1   870 use Digest::MD4 qw/md4_hex/;
  1         945  
  1         49  
10 1     1   309 use CHI;
  0            
  0            
11             use File::HomeDir 0.93;
12             use version 0.77;
13             use Log::Any qw/$log/;
14             use Module::Util qw/find_installed/;
15             use File::Basename qw/dirname/;
16             use File::Spec;
17              
18             our $distname = __PACKAGE__;
19             $distname =~ s/::/-/g;
20              
21             our $CACHE = CHI->new(driver => 'File',
22             root_dir => File::HomeDir->my_dist_data($distname, { create => 1 } ),
23             label => __PACKAGE__,
24             namespace => 'cache',
25             max_key_length => 32);
26              
27             our $VERSION = '0.018'; # VERSION
28             our $CURRENTVERSION;
29             {
30             #
31             # Because $VERSION is generated by dzil, not available in dev. tree
32             #
33             no strict 'vars';
34             $CURRENTVERSION = $VERSION;
35             }
36              
37              
38             # ----------------------------------------------------------------------------------------
39             sub new {
40             my ($class, %opts) = @_;
41              
42             my $grammarName = $opts{grammarName} || 'ECMAScript-262-5';
43             my $cache = $opts{cache} // 0;
44              
45             my $self = {
46             _grammarName => $grammarName,
47             _cache => $cache
48             };
49              
50             bless($self, $class);
51              
52             if (exists($opts{grammarName})) {
53             delete($opts{grammarName});
54             }
55             if (exists($opts{cache})) {
56             delete($opts{cache});
57             }
58              
59             $self->_init(%opts);
60              
61             return $self;
62             }
63              
64             sub _init {
65             my ($self, %opts) = @_;
66              
67             $self->{_grammar} = MarpaX::Languages::ECMAScript::AST::Grammar->new($self->{_grammarName}, %opts);
68             }
69              
70             # ----------------------------------------------------------------------------------------
71              
72              
73             sub describe {
74             my ($self) = @_;
75              
76             my $impl = $self->{_grammar}->program->{impl};
77             my %g0 = ();
78             foreach ($impl->rule_ids('G0')) {
79             $g0{$_} = [ map {$impl->symbol_name($_, 'G0')} $impl->rule_expand($_, 'G0') ];
80             }
81             my %g1 = ();
82             foreach ($impl->rule_ids('G1')) {
83             $g1{$_} = [ map {$impl->symbol_name($_, 'G1')} $impl->rule_expand($_, 'G1') ];
84             }
85              
86             return { G0 => \%g0, G1 => \%g1 };
87             }
88              
89             # ----------------------------------------------------------------------------------------
90              
91              
92             sub grammarAlias {
93             my ($self) = @_;
94              
95             return $self->{_grammar}->grammarAlias;
96              
97             }
98              
99             # ----------------------------------------------------------------------------------------
100              
101              
102             sub templatePath {
103             my ($self) = @_;
104              
105             return File::Spec->catdir(dirname(find_installed(__PACKAGE__)), 'AST', 'Grammar', $self->{_grammar}->grammarAlias, 'Template');
106             }
107              
108             # ----------------------------------------------------------------------------------------
109              
110              
111             sub _getAndCheckHashFromCache {
112             my ($self, $md4, $source, $astp, $fromCachep) = @_;
113              
114             my $rc = 0;
115              
116             my $fromCache = $CACHE->get($md4);
117             if (defined($fromCache)) {
118             my $clearCache = 1;
119             my $store;
120             if (ref($fromCache) eq 'HASH') {
121             $store = $fromCache->{$source};
122             if (defined($store)) {
123             if (ref($store) eq 'HASH') {
124             my $storeVersion = $store->{version};
125             #
126             # Trying to get from cache using the dev files will always clear the cache -;
127             #
128             if (defined($storeVersion) && defined($CURRENTVERSION)) {
129             if (version::is_lax($storeVersion) && version::is_lax($CURRENTVERSION)) {
130             if (version->parse($storeVersion) == version->parse($CURRENTVERSION)) {
131             my $ast = $store->{ast};
132             if (defined($ast)) {
133             $log->tracef('cache ok, storeVersion=%s', $storeVersion);
134             $rc = 1;
135             ${$astp} = $ast;
136             ${$fromCachep} = $fromCache;
137             $clearCache = 0;
138             } else {
139             $log->tracef('cache ko, ast undefined');
140             }
141             } else {
142             $log->tracef('cache ko, storeVersion %s != %s (current version)', $storeVersion, $CURRENTVERSION);
143             }
144             } else {
145             #
146             # In case versions are really garbled, use %s instead of %d
147             #
148             $log->tracef('cache ko, storeVersion %s (is_lax=%s), current version %s (is_lax=%s)', $storeVersion, version::is_lax($storeVersion) || '', $CURRENTVERSION, version::is_lax($CURRENTVERSION) || '');
149             }
150             } else {
151             $log->tracef('cache ko, storeVersion %s, current version %s', $storeVersion || 'undefined', $CURRENTVERSION || 'undefined');
152             }
153             } else {
154             $log->tracef('cache ko, store is a %s', ref($store));
155             }
156             } else {
157             $log->tracef('cache ko, no entry for given source code');
158             }
159             } else {
160             $log->tracef('cache ko, $fromCache is a %s', ref($fromCache));
161             }
162             if ($clearCache) {
163             if (ref($fromCache) eq 'HASH') {
164             #
165             # Invalid data
166             #
167             if (defined($store)) {
168             delete($fromCache->{$source});
169             $CACHE->set($md4, $fromCache);
170             $log->tracef('cache cleaned');
171             }
172             } else {
173             #
174             # Invalid cache
175             #
176             $CACHE->remove($md4);
177             $log->tracef('cache removed');
178             }
179             }
180             } else {
181             $log->tracef('cache ko, no cache for md4 %s', $md4);
182             }
183              
184             return $rc;
185             }
186              
187             sub parse {
188             my ($self, $source) = @_;
189              
190             my $parse = sub {
191             my $grammar = $self->{_grammar}->program->{grammar};
192             my $impl = $self->{_grammar}->program->{impl};
193              
194             return $grammar->parse($source, $impl)->value($impl);
195             };
196              
197             #
198             # If cache is enabled, compute the MD4 and check availability
199             #
200             my $ast;
201             if ($self->{_cache}) {
202             my $md4 = md4_hex($source);
203             my $fromCache = {};
204             if (! $self->_getAndCheckHashFromCache($md4, $source, \$ast, \$fromCache)) {
205             $ast = &$parse();
206             if (defined($CURRENTVERSION)) {
207             $fromCache->{$source} = {ast => $ast, version => $CURRENTVERSION};
208             $CACHE->set($md4, $fromCache);
209             }
210             }
211             } else {
212             $ast = &$parse();
213             }
214              
215             return $ast;
216             }
217              
218             # ----------------------------------------------------------------------------------------
219              
220              
221             sub template {
222             my ($self) = @_;
223              
224             return $self->{_grammar}->template;
225             }
226              
227             # ----------------------------------------------------------------------------------------
228              
229              
230             # ----------------------------------------------------------------------------------------
231              
232             sub stringNumericLiteral {
233             my ($self) = @_;
234              
235             return $self->{_grammar}->stringNumericLiteral;
236             }
237              
238             # ----------------------------------------------------------------------------------------
239              
240              
241             sub pattern {
242             my ($self) = @_;
243              
244             return $self->{_grammar}->pattern;
245             }
246              
247             # ----------------------------------------------------------------------------------------
248              
249              
250             sub JSON {
251             my ($self) = @_;
252              
253             return $self->{_grammar}->JSON;
254             }
255              
256             # ----------------------------------------------------------------------------------------
257              
258              
259             sub URI {
260             my ($self) = @_;
261              
262             return $self->{_grammar}->URI;
263             }
264              
265             # ----------------------------------------------------------------------------------------
266              
267              
268             1;
269              
270             __END__