File Coverage

lib/Hyper/Developer/Generator/Control/ContainerFlow.pm

Criterion	Covered	Total	%
statement	12	12	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	16	16	100.0

package Hyper::Developer::Generator::Control::ContainerFlow;

use strict;
use warnings;
use version; our $VERSION = qv('0.01');

use base qw(Hyper::Developer::Generator::Control);
use Class::Std;
use Parse::RecDescent;
use Hyper::Error;

sub _get_data_ref_of_steps {
    my $self     = shift;
    my $step_ref = shift;

    return {
        map {
            my $name = $_;
               $name =~ s{[^\w]}{_}xmsg;
            $name => {
                control => $step_ref->{$_}->get_controls(),
                action  => $self->_create_action_code($step_ref->{$_}->get_action()),
                transitions => [
                    map {
                        my $destination = $_->get_destination();
                           $destination =~ s{[^\w]}{_}xmsg;
                        $destination => $self->_create_condition_code($_->get_condition());
                    } @{$step_ref->{$_}->get_transitions()}
                ],
            };
        } keys %{$step_ref}
    };
}

sub _get_default_parser :PRIVATE {
    return Parse::RecDescent->new(q{
        line      : expr
                  | { die '__ERROR__'; }
        expr      : { die '__REPLACE_ME__'; }
        mixed     : method
                  | ident
                  | { die '__ERROR__' }
        method    : variables '()'
                    { if ( $item[1]->[0] eq 'this') {
                          shift @{$item[1]};
                      }
                      my $method = pop @{$item[1]};
                      '$self'
                      . (
                          @{$item[1]}
                              ? '->get_value_recursive([qw('
                                . ( join q{ }, @{$item[1]} ) . ')])'
                              : q{}
                      ) . "->$method()";
                    }
        constant  : m{[-]?\d[\d_]*(?: \.(?: \d[\d_])*)?}xms
                  | m{'(?: \\\\' | [^'] )* '}xms
                  | m{"(?: \\\\" | [^"] )* "}xms
        variable  : m{[a-z_][a-z0-9_]*}xmsi
        variables : variable(s /\./)
        ident     : constant
                  | variables
                    { if ( $item[1]->[0] eq 'this') {
                         shift @{$item[1]};
                      }
                      '$self'
                      . (
                          @{$item[1]}
                              ? '->get_value_recursive([qw('
                                . ( join q{ }, @{$item[1]} ) . ')])'
                              : q{}
                      );
                    }
    });
}

sub _create_action_code :RESTRICTED {
    my $self   = shift;
    my $param  = shift;

    return q{} if ! defined $param;

    my $parser = $self->_get_default_parser();

    $parser->Extend(q{
        terminator : m{ \s* ;* \s* (\#.*)? \z }xms
                     { return q{} }
    });
    $parser->Replace(q{
        expr : variables '=' mixed terminator
               { chomp $item{mixed};
                 $item{mixed} =~ s{\s*\;$}{};
                 "\$self->set_value_recursive("
                  . '[qw('
                  . ( join q{ }, @{$item{variables}} )
                  . ")], $item{mixed});"
               }
             | method
               { "$item{method};" }
    });

    # return input converted to grammar
    my $result = eval {
        join "\n", map { $parser->line($_) } split m{\n}, $param;
    };

    throw("$@ Error generating action code near\n$param") if $@;

    return $result;
}

sub _create_condition_code :RESTRICTED {
    my $self   = shift;
    my $param  = shift;

    return q{} if ! defined $param;

    my $parser = $self->_get_default_parser();

    $parser->Extend(q{
        logop : 'eq' | 'ne' | '==' | '!=' | '||' | '&&' | 'or' | 'and'
    });

    $parser->Replace(q{
        expr  : mixed logop expr
                { join q{ }, @item[1..3] }
              | mixed
    });

    # return input converted to grammar
    my $result = eval {
        join "\n", map { $parser->line($_); } split m{\n}, $param;
    };

    throw("$@ Error generating condition code near\n $param") if $@;

    return $result;
}

1;
__END__