view release on metacpan or  search on metacpan

inc/TestML/Runtime.pm  view on Meta::CPAN

package TestML::Runtime;

use TestML::Base;

has testml => ();
has bridge => ();
has library => ();
has compiler => ();
has skip => ();

has function => ();
has error => ();
has global => ();
has base => ();

sub BUILD {
    my ($self) = @_;
    $TestML::Runtime::Singleton = $self;
    $self->{base} ||= $0 =~ m!(.*)/! ? $1 : ".";
}

sub run {
    my ($self) = @_;
    $self->compile_testml;
    $self->initialize_runtime;
    $self->run_function($self->{function}, []);
}

# TODO Functions should have return values
sub run_function {
    my ($self, $function, $args) = @_;

    $self->apply_signature($function, $args);

    my $parent = $self->function;
    $self->{function} = $function;

    for my $statement (@{$function->statements}) {
        if (ref($statement) eq 'TestML::Assignment') {
            $self->run_assignment($statement);
        }
        else {
            $self->run_statement($statement);
        }
    }
    $self->{function} = $parent;
    return;
}

sub apply_signature {
    my ($self, $function, $args) = @_;
    my $signature = $function->signature;

    die sprintf(
        "Function received %d args but expected %d",
        scalar(@$args),
        scalar(@$signature),
    ) if @$signature and @$args != @$signature;

    $function->setvar('Self', $function);
    for (my $i = 0; $i < @$signature; $i++) {
        my $arg = $args->[$i];
        $arg = $self->run_expression($arg)
            if ref($arg) eq 'TestML::Expression';
        $function->setvar($signature->[$i], $arg);
    }
}

sub run_statement {
    my ($self, $statement) = @_;
    my $blocks = $self->select_blocks($statement->points || []);
    for my $block (@$blocks) {
        $self->function->setvar('Block', $block) if $block != 1;

inc/TestML/Runtime.pm  view on Meta::CPAN

            $self->function->setvar($name, $callable);
            return $callable;
        }
    }
    return;
}

sub get_point {
    my ($self, $name) = @_;
    my $value = $self->function->getvar('Block')->{points}{$name};
    defined $value or return;
    if ($value =~ s/\n+\z/\n/ and $value eq "\n") {
        $value = '';
    }
    $value =~ s/^\\//gm;
    return TestML::Str->new(value => $value);
}

sub select_blocks {
    my ($self, $wanted) = @_;
    return [1] unless @$wanted;
    my $selected = [];

    OUTER: for my $block (@{$self->function->data}) {
        my %points = %{$block->points};
        next if exists $points{SKIP};
        if (exists $points{ONLY}) {
            for my $point (@$wanted) {
                return [] unless exists $points{$point};
            }
            $selected = [$block];
            last;
        }
        for my $point (@$wanted) {
            next OUTER unless exists $points{$point};
        }
        push @$selected, $block;
        last if exists $points{LAST};
    }
    return $selected;
}

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

    die "'testml' document required but not found"
        unless $self->testml;
    if ($self->testml !~ /\n/) {
        $self->testml =~ /(?:(.*)\/)?(.*)/ or die;
        $self->{testml} = $2;
        $self->{base} .= '/' . $1 if $1;
        $self->{testml} = $self->read_testml_file($self->testml);
    }
    $self->{function} = $self->compiler->new->compile($self->testml)
        or die "TestML document failed to compile";
}

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

    $self->{global} = $self->function->outer;

    $self->{global}->setvar(Block => TestML::Block->new);
    $self->{global}->setvar(Label => TestML::Str->new(value => '$BlockLabel'));
    $self->{global}->setvar(True => $TestML::Constant::True);
    $self->{global}->setvar(False => $TestML::Constant::False);
    $self->{global}->setvar(None => $TestML::Constant::None);
    $self->{global}->setvar(TestNumber => TestML::Num->new(value => 0));
    $self->{global}->setvar(Library => TestML::List->new);

    my $library = $self->function->getvar('Library');
    for my $lib ($self->bridge, $self->library) {
        if (ref($lib) eq 'ARRAY') {
            $library->push($_->new) for @$lib;
        }
        else {
            $library->push($lib->new);
        }
    }
}

sub get_label {
    my ($self) = @_;
    my $label = $self->function->getvar('Label') or return;
    $label = $label->value or return;
    $label =~ s/\$(\w+)/$self->replace_label($1)/ge;
    return $label;
}

sub replace_label {
    my ($self, $var) = @_;
    my $block = $self->function->getvar('Block');
    return $block->label if $var eq 'BlockLabel';
    if (my $v = $block->points->{$var}) {
        $v =~ s/\n.*//s;
        $v =~ s/^\s*(.*?)\s*$/$1/;
        return $v;
    }
    if (my $v = $self->function->getvar($var)) {
        return $v->value;
    }
}

sub read_testml_file {
    my ($self, $file) = @_;
    my $path = $self->base . '/' . $file;
    open my $fh, $path
        or die "Can't open '$path' for input: $!";
    local $/;
    return <$fh>;
}

#-----------------------------------------------------------------------------
package TestML::Function;

use TestML::Base;

has type => 'Func';     # Functions are TestML typed objects
has signature => [];    # Input variable names
has namespace => {};    # Lexical scoped variable stash
has statements => [];   # Exexcutable code statements
has data => [];         # Data section scoped to this function

my $outer = {};
sub outer { @_ == 1 ? $outer->{$_[0]} : ($outer->{$_[0]} = $_[1]) }

sub getvar {
    my ($self, $name) = @_;
    while ($self) {