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

use strict;
use warnings FATAL => 'all';

package MarpaX::Languages::ECMAScript::AST;

# ABSTRACT: Translate a ECMAScript source to an AST

use MarpaX::Languages::ECMAScript::AST::Grammar qw//;
use Digest::MD4 qw/md4_hex/;
use CHI;
use File::HomeDir 0.93;
use version 0.77;
use Log::Any qw/$log/;
use Module::Util qw/find_installed/;
use File::Basename qw/dirname/;
use File::Spec;

our $distname = __PACKAGE__;
$distname =~ s/::/-/g;

our $CACHE = CHI->new(driver => 'File',
                      root_dir => File::HomeDir->my_dist_data($distname, { create => 1 } ),
                      label => __PACKAGE__,
                      namespace => 'cache',
		      max_key_length => 32);

our $VERSION = '0.019'; # VERSION
our $CURRENTVERSION;
{
  #
  # Because $VERSION is generated by dzil, not available in dev. tree
  #
  no strict 'vars';
  $CURRENTVERSION = $VERSION;
}


# ----------------------------------------------------------------------------------------
sub new {
  my ($class, %opts) = @_;

  my $grammarName = $opts{grammarName} || 'ECMAScript-262-5';
  my $cache       = $opts{cache} // 0;

  my $self  = {
      _grammarName => $grammarName,
      _cache       => $cache
  };

  bless($self, $class);

  if (exists($opts{grammarName})) {
      delete($opts{grammarName});
  }
  if (exists($opts{cache})) {
      delete($opts{cache});
  }

  $self->_init(%opts);

  return $self;
}

sub _init {
    my ($self, %opts) = @_;

    $self->{_grammar} = MarpaX::Languages::ECMAScript::AST::Grammar->new($self->{_grammarName}, %opts);
}

# ----------------------------------------------------------------------------------------


sub describe {
    my ($self) = @_;

    my $impl = $self->{_grammar}->program->{impl};
    my %g0 = ();
    foreach ($impl->rule_ids('G0')) {
      $g0{$_} = [ map {$impl->symbol_name($_, 'G0')} $impl->rule_expand($_, 'G0') ];
    }
    my %g1 = ();
    foreach ($impl->rule_ids('G1')) {
      $g1{$_} = [ map {$impl->symbol_name($_, 'G1')} $impl->rule_expand($_, 'G1') ];
    }

    return { G0 => \%g0, G1 => \%g1 };
}

# ----------------------------------------------------------------------------------------


sub grammarAlias {
  my ($self) = @_;

  return $self->{_grammar}->grammarAlias;

}

# ----------------------------------------------------------------------------------------


sub templatePath {
  my ($self) = @_;

  return File::Spec->catdir(dirname(find_installed(__PACKAGE__)), 'AST', 'Grammar',  $self->{_grammar}->grammarAlias, 'Template');
}

# ----------------------------------------------------------------------------------------


sub _getAndCheckHashFromCache {
  my ($self, $md4, $source, $astp, $fromCachep) = @_;

  my $rc = 0;

  my $fromCache = $CACHE->get($md4);
  if (defined($fromCache)) {
    my $clearCache = 1;
    my $store;
    if (ref($fromCache) eq 'HASH') {
      $store = $fromCache->{$source};
      if (defined($store)) {
        if (ref($store) eq 'HASH') {
          my $storeVersion = $store->{version};
          #
          # Trying to get from cache using the dev files will always clear the cache -;
          #
          if (defined($storeVersion) && defined($CURRENTVERSION)) {
            if (version::is_lax($storeVersion) && version::is_lax($CURRENTVERSION)) {
              if (version->parse($storeVersion) == version->parse($CURRENTVERSION)) {
                my $ast = $store->{ast};
                if (defined($ast)) {
                  $log->tracef('cache ok, storeVersion=%s', $storeVersion);
                  $rc = 1;
                  ${$astp} = $ast;
                  ${$fromCachep} = $fromCache;
                  $clearCache = 0;
                } else {
                  $log->tracef('cache ko, ast undefined');
                }
              } else {
                $log->tracef('cache ko, storeVersion %s != %s (current version)', $storeVersion, $CURRENTVERSION);
              }
            } else {
              #
              # In case versions are really garbled, use %s instead of %d
              #
              $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) || '');
            }
          } else {
            $log->tracef('cache ko, storeVersion %s, current version %s', $storeVersion || 'undefined', $CURRENTVERSION || 'undefined');
          }
        } else {
          $log->tracef('cache ko, store is a %s', ref($store));
        }
      } else {
        $log->tracef('cache ko, no entry for given source code');
      }
    } else {
      $log->tracef('cache ko, $fromCache is a %s', ref($fromCache));
    }
    if ($clearCache) {
      if (ref($fromCache) eq 'HASH') {
        #
        # Invalid data
        #
        if (defined($store)) {
          delete($fromCache->{$source});
          $CACHE->set($md4, $fromCache);
          $log->tracef('cache cleaned');
        }
      } else {
        #
        # Invalid cache
        #
        $CACHE->remove($md4);
        $log->tracef('cache removed');
      }
    }
  } else {
    $log->tracef('cache ko, no cache for md4 %s', $md4);
  }

  return $rc;
}

sub parse {
  my ($self, $source) = @_;

  my $parse = sub {
      my $grammar     = $self->{_grammar}->program->{grammar};
      my $impl        = $self->{_grammar}->program->{impl};

      return $grammar->parse($source, $impl)->value($impl);
  };

  #
  # If cache is enabled, compute the MD4 and check availability
  #
  my $ast;
  if ($self->{_cache}) {
    my $md4 = md4_hex($source);
    my $fromCache = {};
    if (! $self->_getAndCheckHashFromCache($md4, $source, \$ast, \$fromCache)) {
      $ast = &$parse();
      if (defined($CURRENTVERSION)) {
        $fromCache->{$source} = {ast => $ast, version => $CURRENTVERSION};
        $CACHE->set($md4, $fromCache);
      }
    }
  } else {
    $ast = &$parse();
  }

  return $ast;
}

# ----------------------------------------------------------------------------------------


sub template {
  my ($self) = @_;

  return $self->{_grammar}->template;
}

# ----------------------------------------------------------------------------------------


# ----------------------------------------------------------------------------------------

sub stringNumericLiteral {
  my ($self) = @_;

  return $self->{_grammar}->stringNumericLiteral;
}

# ----------------------------------------------------------------------------------------


sub pattern {
  my ($self) = @_;

  return $self->{_grammar}->pattern;
}

# ----------------------------------------------------------------------------------------


sub JSON {
  my ($self) = @_;

  return $self->{_grammar}->JSON;
}

# ----------------------------------------------------------------------------------------


sub URI {
  my ($self) = @_;

  return $self->{_grammar}->URI;
}

# ----------------------------------------------------------------------------------------


1;

__END__