File Coverage

blib/lib/Outthentic/DSL.pm

Criterion	Covered	Total	%
statement	146	389	37.5
branch	36	208	17.3
condition	10	37	27.0
subroutine	24	33	72.7
pod	3	19	15.7
total	219	686	31.9

package Outthentic::DSL;

use strict;

our $VERSION = '0.2.9';

use Carp;
use Data::Dumper;
use Outthentic::DSL::Context::Range;
use Outthentic::DSL::Context::Default;
use Outthentic::DSL::Context::TextBlock;
use File::Temp qw/ tempfile /;
use JSON;

$Data::Dumper::Terse=1;

sub results {

    my $self = shift;

    $self->{results};
}

sub add_result {

    my $self = shift;
    my $item = shift;

    push @{$self->results}, { %{$item}, type => 'check_expression' };

}

sub debug {

    my $self = shift;
    my $item = shift;

    push @{$self->results}, { message => $item , type => 'debug' };

}


sub new {

    my $class = shift;
    my $output = shift;
    my $opts = shift || {};

    bless {
        results => [],
        original_context => [],
        current_context => [],
        context_modificator => Outthentic::DSL::Context::Default->new(),
        has_context => 0,
        succeeded => [],
        captures => [],
        within_mode => 0,
        block_mode => 0,
        last_match_line => undef,
        last_check_status => undef,
        debug_mod => 0,
        output => $output||'',
        match_l => 40,
        stream => {},
        languages => {},
        %{$opts},
    }, __PACKAGE__;

}

sub create_context {

    my $self = shift;

    return if $self->{has_context};

    my $i = 0;

    my @original_context = ();

    for my $l ( split /\n/, $self->{output} ){
        chomp $l;
        $i++;
        $l=":blank_line" unless $l=~/\S/;
        push @original_context, [$l, $i];

        $self->debug("[oc] [$l, $i]") if $self->{debug_mod} >= 2;

    }

    $self->{original_context} = [@original_context];

    $self->{current_context} = [@original_context];

    $self->debug('context populated') if $self->{debug_mod} >= 2;


    $self->{has_context} = 1;


}


sub reset_context {

    my $self = shift;

    $self->{current_context} = $self->{original_context};

    $self->debug('reset search context') if $self->{debug_mod} >= 2;

    $self->{context_modificator} = Outthentic::DSL::Context::Default->new();

}

sub reset_captures {

    my $self = shift;
    $self->{captures} = [];
    unlink $self->{cache_dir}."/captures.json" if -f $self->{cache_dir}."/captures.json";
}

sub reset_succeeded {

    my $self = shift;
    $self->{succeeded} = [];

}


sub stream {

    my $self = shift;
    my @stream;
    my $i=0;

    for my $cid ( sort { $a <=> $b } keys  %{$self->{stream}} ){
        $stream[$i]=[];
        for my $c (@{$self->{stream}->{$cid}}){
            push @{$stream[$i]}, $c->[0];
            $self->debug("[stream {$cid}] $c->[0]") if $self->{debug_mod} >= 2;
        }
        $i++;
    }
    [@stream]
}

sub match_lines {

    my $self = shift;
    return $self->{succeeded};
}


sub check_line {

    my $self = shift;
    my $pattern = shift;
    my $check_type = shift;
    my $message = shift;

    my $status = 0;

    s/\s+$// for $pattern;

    $self->reset_captures;

    my @captures = ();

    $self->create_context;

    $self->debug("[lookup] $pattern ...") if $self->{debug_mod} >= 2;

    my @original_context   = @{$self->{original_context}};
    my @context_new        = ();

    # dynamic context
    my $dc = $self->{context_modificator}->change_context(
        $self->{current_context},
        $self->{original_context},
        $self->{succeeded}
    );

    $self->debug("context modificator applied: ".(ref $self->{context_modificator}))
        if $self->{debug_mod} >=2;

    if ( $self->{debug_mod} >= 2 ) {
        for my $dcl (@$dc){
            $self->debug("[dc] $dcl->[0]");
        }

    };


    $self->reset_succeeded;

    if ($check_type eq 'default'){
        for my $c (@{$dc}){

            my $ln = $c->[0];

            next if $ln =~/#dsl_note:/; # skip debug entries

            if ( index($ln,$pattern) != -1){
                $status = 1;
                $self->{last_match_line} = $ln;
                push @{$self->{succeeded}}, $c;
            }
        }

    }elsif($check_type eq 'regexp'){


        for my $c (@{$dc}) {

            my $re = qr/$pattern/;

            my $ln = $c->[0];

            next if $ln eq ":blank_line";
            next if $ln =~/#dsl_note:/;

            my @foo = ($ln =~ /$re/g);

            if (scalar @foo){
                push @captures, [@foo];
                $status = 1;
                push @{$self->{succeeded}}, $c;
                push @context_new, $c if $self->{within_mode};
                $self->{last_match_line} = $ln;
            }

        }
    }else {
        confess "unknown check_type: $check_type";
    }



    $self->{last_check_status} = $status;

    if ( $self->{debug_mod} >= 2 ){

        my $i = 1;
        my $j = 1;
        for my $cpp (@captures){
            for my $cp (@{$cpp}){
                $self->debug("CAP[$i,$j]: $cp");
                $j++;
            }
            $i++;
            $j=1;
        }

        for my $s (@{$self->{succeeded}}){
            $self->debug("SUCC: $s->[0]");
        }
    }

    $self->{captures} = [ @captures ];

    if ($self->{cache_dir}){
      open CAPTURES, '>', $self->{cache_dir}.'/captures.json'
        or confess "can't open ".($self->{cache_dir})."captures.json to write $!";
      print CAPTURES encode_json($self->{captures});
      $self->debug("CAPTURES saved at ".$self->{cache_dir}.'/captures.json')
        if $self->{debug_mod} >= 1;
      close CAPTURES;
    }

    # update context
    if ( $self->{within_mode} and $status ){
        $self->{current_context} = [@context_new];
        $self->debug("[WITH] within mode: modify search context to: $context_new[0][0]")
          if $self->{debug_mod} >= 2
    }elsif ( $self->{within_mode} and ! $status ){
        $self->{current_context} = []; # empty context if within expression has not passed
        $self->debug('within mode: modify search context to: '.(Dumper([@context_new]))) if $self->{debug_mod} >= 2
    }

    $self->add_result({ status => $status , message => $message });


    $self->{context_modificator}->update_stream(
        $self->{current_context},
        $self->{original_context},
        $self->{succeeded},
        \($self->{stream}),
    );

    return $status;

}

sub validate {

    my $self        = shift;
    my $check_list  = shift;

    my $block_type;
    my @multiline_block;
    my $here_str_mode = 0;
    my $here_str_marker;

    my @lines;
    if (  -f $check_list ){
      open my $ff, $check_list or die "can't open file check_list to read: $!";
      while (my $ii = <$ff>){
        push @lines, $ii;
      }
      close $ff;
    } else {
     @lines = ( ref $check_list  ) ? @{$check_list} : ( split "\n", $check_list );
    }

    LINE: for my $l ( @lines ) {

        chomp $l;

        $self->debug("[dsl::$block_type] $l") if $self->{debug_mod} >= 2;

        next LINE unless $l =~ /\S/; # skip blank lines

        next LINE if $l=~ /^\s*#(.*)/; # skip comments

        if ($here_str_mode && $l=~s/^$here_str_marker\s*$//) {

          $here_str_mode = 0;

          $self->debug("here string mode off") if $self->{debug_mod} >= 2;

          $self->debug("flushing $block_type block") if $self->{debug_mod} >= 2;

          no strict 'refs';

          my $name = "handle_";

          $name.=$block_type;

          &$name($self, [ @multiline_block ] );

          undef @multiline_block; undef $block_type;

          next LINE;

        }

        if ( $block_type and $l!~/\\\s*$/ and ! $here_str_mode  ){

          no strict 'refs';

          my $name = "handle_";

          $name.=$block_type;

          $self->debug("flushing $block_type block") if $self->{debug_mod} >= 2;

          &$name($self, [ @multiline_block ] );

          undef @multiline_block; undef $block_type;


        }

        if ( $block_type and $l=~/^\s*(code|generator|validator):\s*(.*)/ and ! $here_str_mode  ){

          no strict 'refs';

          my $name = "handle_";

          $name.=$block_type;

          $self->debug("flushing $block_type block") if $self->{debug_mod} >= 2;

          &$name($self, [ @multiline_block ] );

          undef @multiline_block; undef $block_type;


        }

        if ( $block_type && ( $l=~s/\\\s*$// or $here_str_mode )) { # multiline block

           # this is multiline block or here string,
           # accumulate lines until meet line not ending with '\' ( for multiline blocks )
           # or here string end marker ( for here stings )

           push @multiline_block, $l;

           next LINE;

        }



        if ( $l=~/^\s*begin:\s*$/) { # begining  of the text block

            do { undef @multiline_block; undef $block_type } if $block_type;

            die "you can't switch to text block mode when within mode is enabled" if $self->{within_mode};

            $self->{context_modificator} = Outthentic::DSL::Context::TextBlock->new();

            $self->debug('text block start') if $self->{debug_mod} >= 2;

            $self->{block_mode} = 1;

            $self->reset_succeeded();

        } elsif ($l=~/^\s*end:\s*$/) { # end of the text block

            $self->{block_mode} = 0;

            $self->reset_context();

            $self->debug('text block end') if $self->{debug_mod} >= 2;

        } elsif ($l=~/^\s*reset_context:\s*$/) {

            do { undef @multiline_block; undef $block_type } if $block_type;
            $self->reset_context();

        } elsif ($l=~/^\s*assert:\s+(\d+)\s+(.*)/) {

            my $status = $1; my $message = $2;

            do { undef @multiline_block; undef $block_type } if $block_type;

            $self->debug("assert found: $status | $message") if $self->{debug_mod} >= 2;

            $status = 0 if $status eq 'false'; # ruby to perl5 conversion

            $status = 1 if $status eq 'true'; # ruby to perl5 conversion

            $self->add_result({ status => $status , message => $message });

        } elsif ($l=~/^\s*between:\s+(.*)/) { # range context


            die "you can't switch to range context mode when within mode is enabled"  if $self->{within_mode};
            die "you can't switch to range context mode when block mode is enabled"   if $self->{block_mode};

            my $pattern = $1;

            do { undef @multiline_block; undef $block_type } if $block_type;

            $self->{context_modificator} = Outthentic::DSL::Context::Range->new($1);


        } elsif ($l=~/^\s*(code|generator|validator):\s*(.*)/)  {

            my $my_block_type = $1;

            my $code = $2;

            if ( $code=~s/(.*)\\\s*$// ) {

                 # this is multiline block, accumulate lines until meet '\' line
                 $block_type = $my_block_type;
                 my $first_line = $1;
                 push @multiline_block, $first_line;

                 $self->debug("starting $block_type block") if $self->{debug_mod}  >= 2;
                 $self->debug("first line in block: <<<$first_line>>>") if $self->{debug_mod}  >= 2;

            } elsif ( $code=~s/<<(\S+)// ) {

                $block_type = $my_block_type;

                $here_str_mode = 1;

                $here_str_marker = $1;

                $self->debug("$block_type block start. heredoc marker: $here_str_marker") if $self->{debug_mod}  >= 2;


            } else {

                $self->debug("one-line $my_block_type found: $code") if $self->{debug_mod}  >= 2;

                no strict 'refs';

                my $name = "handle_";

                $name.=$my_block_type;

                $self->debug("flushing one-line $block_type block") if $self->{debug_mod} >= 2;

                &$name($self,$code);


            }

        } elsif ($l=~/^\s*regexp:\s*(.*)/) { # `regexp' line

            my $re = $1;

            $re=~s/\s+#.*//;

            $re=~s/^\s+//;

            $self->handle_regexp($re);

        } elsif ($l=~/^\s*within:\s*(.*)/) {

            die "you can't switch to within mode when text block mode is enabled" if $self->{block_mode};

            my $re = $1;

            $re=~s/\s+#.*//;

            $re=~s/^\s+//;

            $self->handle_within($re);

        } else { # `plain string' line

            $l=~s/\s+#.*//;

            $l=~s/^\s+//;

            $self->handle_plain($l);

        }
    }

    if ( $block_type ){

      no strict 'refs';

      my $name = "handle_";

      $self->debug("flushing $block_type block") if $self->{debug_mod} >= 2;

      $name.=$block_type;

      &$name($self, [ @multiline_block ] );

      undef @multiline_block; undef $block_type;


    }

}


sub handle_code {

    my $self = shift;
    my $code = shift;
    my $results;

    if (! ref $code) {

        $results = eval "package main; $code;";
        confess "eval error; sub:handle_code; code:$code\nerror: $@" if $@;
        $self->debug("code OK. single line. code: $code") if $self->{debug_mod} >= 3;

    } else {

        my $i = 0;

        my $code_to_print = join "\n", map { my $v=$_; $i++; "[$i] $v" }  @$code;

        if ($code->[0]=~s/^\!(.*)//) {

          my $ext_runner = $1;

          my $language = (split /\\/, $ext_runner)[-1];

          if ($language eq 'perl') {

              shift @$code;
              my $code_to_eval = join "\n", @$code;
              $results = eval "package main; $code_to_eval";
              confess "eval error; sub:handle_code; code:\n$code_to_print\nerror: $@" if $@;
              $self->debug("code OK. inline(perl). $code_to_eval") if $self->{debug_mod} >= 3;

          } else {

            my $source_file = File::Temp->new( DIR => $self->{cache_dir} , UNLINK => 0 );

            shift @$code;

            my $code_to_eval = join "\n", @$code;

            open SOURCE_CODE, '>', $source_file or die "can't open source code file $source_file to write: $!";

            print SOURCE_CODE $code_to_eval;

            close SOURCE_CODE;

            if ($language eq 'bash'){

              if ($self->{languages}->{$language}){
                $ext_runner = "bash -c '".($self->{languages}->{$language})." && source $source_file'";
              }else{
                  $ext_runner = "bash -c 'source $source_file'";
              }

            } else {
              $ext_runner = $self->{languages}->{$language} if $self->{languages}->{$language};
              $ext_runner.=' '.$source_file;
            }


            my $st = system("$ext_runner 2>$source_file.err 1>$source_file.out");

            if ($st != 0){
              confess "$ext_runner failed, see $source_file.err for details";
            }

            $self->debug("code OK. inline. $ext_runner") if $self->{debug_mod} >= 2;

            open EXT_OUT, "$source_file.out" or die "can't open file $source_file.out to read: $!";
            $results = join "", ;
            close EXT_OUT;

            unless ($ENV{OTX_KEEP_SOURCE_FILES}) {
              unlink("$source_file.out");
              unlink("$source_file.err");
              unlink("$source_file");
            }
        }



      } else {

        my $code_to_eval = join "\n", @$code;
        $results = eval "package main; $code_to_eval";
        confess "eval error; sub:handle_code; code:\n$code_to_print\nerror: $@" if $@;
        $self->debug("code OK. multiline. $code_to_eval") if $self->{debug_mod} >= 3;

      }


  }

  return $results;

}

sub handle_validator {

    my $self = shift;
    my $code = shift;

    if (! defined ($self->{last_check_status}) or $self->{last_check_status}){
      my $r = $self->handle_code($code);
      $self->add_result({ status => $r->[0] , message => $r->[1] });
    } else {
      $self->debug("skip validator step because last check has been failed") if $self->{debug_mod} >= 1;
    }


}

sub handle_generator {

    my $self = shift;
    my $code = shift;

    if (! defined ($self->{last_check_status}) or $self->{last_check_status}){
      $self->validate(
        $self->handle_code($code)
      )
    } else {
      $self->debug("skip generator step because last check has been failed") if $self->{debug_mod} >= 1;
    }


}

sub handle_simple {

  my $self    = shift;
  my $pattern = shift;
  my $check_type = shift;

  my $msg;

  my $lshort =  $self->_short_string($pattern);

  my $reset_context = 0;

  if ($self->{within_mode}) {

      $self->{within_mode} = 0;

      $reset_context = 1;

      if ($self->{last_check_status}){
        if ($check_type eq 'regexp'){
          $msg = "'".($self->_short_string($self->{last_match_line}))."' match /$lshort/"
        } else {
          $msg = "'".($self->_short_string($self->{last_match_line}))."' has '".$lshort."'"
        }
      } else {
        if ($check_type eq 'regexp'){
          $msg = "text match /$lshort/"
        } else {
          $msg = "text has '".$lshort."'"
        }
      }


  } else {

      if ($self->{block_mode}){
        if ($check_type eq 'regexp'){
          $msg = "[b] text match /$lshort/";
        } else {
          $msg = "[b] text has '".$lshort."'";
        }
      } else {
        if ($check_type eq 'regexp'){
          $msg = "text match /$lshort/";
        } else {
          $msg = "text has '".$lshort."'";
        }
      }
  }


  $self->check_line($pattern,$check_type, $msg);

  $self->reset_context if $reset_context;

  $self->debug("$check_type check DONE. >>> <<<$pattern>>>") if $self->{debug_mode} >= 3;

}

sub handle_regexp {

    my $self  = shift;
    my $re    = shift;

    $self->handle_simple($re, 'regexp');

}

sub handle_within {

    my $self    = shift;
    my $pattern = shift;

    my $msg;

    if ($self->{within_mode}) {
      if ($self->{last_check_status}){
        $msg = "'".($self->_short_string($self->{last_match_line}))."' match  /$pattern/"
      } else {
        $msg = "text match /$pattern/"
      }

    }else{
        $msg = "text match /$pattern/";
    }

    $self->{within_mode} = 1;

    $self->check_line($pattern,'regexp', $msg);

    $self->debug("within check DONE. >>> <<<$pattern>>>") if $self->{debug_mode} >= 3;

}

sub handle_plain {

    my $self = shift;
    my $l = shift;

    $self->handle_simple($l, 'default');

}


sub _short_string {

    my $self = shift;
    my $str = shift;
    my $sstr = substr( $str, 0, $self->{match_l} );

    s{\r}[]g for $str;
    s{\r}[]g for $sstr;

    s/\s+$// for $sstr;
    s/\s+$// for $str;

    return $sstr < $str ? "$sstr ..." : $sstr;

}

1;

__END__