File Coverage

blib/lib/App/RecordStream/DomainLanguage/Snippet.pm

Criterion	Covered	Total	%
statement	68	76	89.4
branch	8	12	66.6
condition	9	14	64.2
subroutine	9	9	100.0
pod	0	2	0.0
total	94	113	83.1

package App::RecordStream::DomainLanguage::Snippet;

use strict;
use warnings;

use App::RecordStream::DomainLanguage::Executor;
use App::RecordStream::DomainLanguage::Value;
use App::RecordStream::Executor;

sub new
{
  my $class = shift;
  my $code = shift;
  my $vars = shift;

  $code = App::RecordStream::Executor->transform_code($code);
  $code = _transform_angles($code);

  my $this =
  {
    'CODE' => $code,
    'VARS' => $vars,
  };

  bless $this, $class;

  return $this;
}

sub evaluate_as
{
  my $this = shift;
  my $type = shift;
  my $vars = shift || {};

  my $executor = App::RecordStream::DomainLanguage::Executor->new();
  $executor->import_registry();

  for my $var (%{$this->{'VARS'}})
  {
      for my $ref (@{$this->{'VARS'}->{$var}})
      {
          $executor->set_ref($var, $ref);
      }
  }

  for my $var (keys(%$vars))
  {
    if(0)
    {
    }
    elsif($var =~ /^\$(.*)$/)
    {
      $executor->set_scalar($1, $vars->{$var});
    }
    else
    {
      die "Bad var for snippet: '$var'";
    }
  }
  my $result = $executor->exec($this->{'CODE'});

  return App::RecordStream::DomainLanguage::Value::cast_or_die($type, $result);
}

sub _transform_angles
{
  my $code = shift;

  my $pos = 0;
  my $out = '';
  while(1)
  {
    my $top_level_entrance = index($code, '<<', $pos);
    if($top_level_entrance == -1)
    {
      $out .= substr($code, $pos);
      last;
    }

    my $level = 1;
    my $pos2 = $top_level_entrance + 2;
    my $top_level_exit;
    while(1)
    {
      my $next_enter = index($code, '<<', $pos2);
      my $next_exit = index($code, '>>', $pos2);

      if($next_enter != -1 && ($next_exit == -1 || $next_enter < $next_exit))
      {
        ++$level;
        $pos2 = $next_enter + 2;
        next;
      }

      if($next_exit != -1 && ($next_enter == -1 || $next_exit < $next_enter))
      {
        --$level;
        if($level == 0)
        {
          $top_level_exit = $next_exit;
          last;
        }
        $pos2 = $next_enter + 2;
        next;
      }

      die "Unbalanced << and >> in snippet: $code";
    }

    $out .= substr($code, $pos, $top_level_entrance - $pos);
    $out .= _quote_snippet(substr($code, $top_level_entrance + 2, $top_level_exit - $top_level_entrance - 2));
    $pos = $top_level_exit + 2;
  }

  return $out;
}

sub _quote_snippet
{
    my $code = shift;

    my @vars;
    if($code =~ s/^([a-zA-Z_][a-zA-Z_0-9]*(,[a-zA-Z_][a-zA-Z_0-9]*)*)\|//)
    {
        @vars = split(/,/, $1);
    }

    # Could not get typeglobs to work.  References go in, references come out,
    # you can't explain that...
    return "snip(App::RecordStream::DomainLanguage::Snippet->new('$code', {" . join(", ", map { "'$_' => [\\\$$_, \\\@$_, \\\%$_]" } @vars) . "}))";
}

1;