File Coverage

blib/lib/TestML1/Compiler.pm

Criterion	Covered	Total	%
statement	55	59	93.2
branch	24	38	63.1
condition	3	6	50.0
subroutine	4	4	100.0
pod	0	2	0.0
total	86	109	78.9

use TestML1::Runtime;

package TestML1::Compiler;

use TestML1::Base;

has code => ();
has data => ();
has text => ();
has directives => ();
has function => ();

sub compile {
    my ($self, $input) = @_;

    $self->preprocess($input, 'top');
    $self->compile_code;
    $self->compile_data;

    if ($self->directives->{DumpAST}) {
        XXX($self->function);
    }

    $self->function->namespace->{TestML} = $self->directives->{TestML};

    $self->function->outer(TestML1::Function->new);
    return $self->function;
}

sub preprocess {
    my ($self, $input, $top) = @_;

    my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $input;
    $input = '';

    $self->{directives} = {
        TestML => '',
        DataMarker => '',
        BlockMarker => '===',
        PointMarker => '---',
    };

    my $order_error = 0;
    for my $part (@parts) {
        next unless length($part);
        if ($part =~ /^(\#.*|\ *)\n/) {
            $input .= "\n";
            next;
        }
        if ($part =~ /^%(\w+)\s*(.*?)\s*\n/) {
            my ($directive, $value) = ($1, $2);
            $input .= "\n";
            if ($directive eq 'TestML') {
                die "Invalid TestML directive"
                    unless $value =~ /^\d+\.\d+\.\d+$/;
                die "More than one TestML directive found"
                    if $self->directives->{TestML};
                $self->directives->{TestML} =
                    TestML1::Str->new(value => $value);
                next;
            }
            $order_error = 1 unless $self->directives->{TestML};
            if ($directive eq 'Include') {
                my $runtime = $TestML1::Runtime::Singleton
                    or die "Can't process Include. No runtime available";
                my $include = ref($self)->new;
                $include->preprocess($runtime->read_testml_file($value));
                $input .= $include->text;
                $self->directives->{DataMarker} =
                    $include->directives->{DataMarker};
                $self->directives->{BlockMarker} =
                    $include->directives->{BlockMarker};
                $self->directives->{PointMarker} =
                    $include->directives->{PointMarker};
                die "Can't define %TestML in an Included file"
                    if $include->directives->{TestML};
            }
            elsif ($directive =~ /^(DataMarker|BlockMarker|PointMarker)$/) {
                $self->directives->{$directive} = $value;
            }
            elsif ($directive =~ /^(DebugPegex|DumpAST)$/) {
                $value = 1 unless length($value);
                $self->directives->{$directive} = $value;
            }
            else {
                die "Unknown TestML directive '$directive'";
            }
        }
        else {
            $order_error = 1 if $input and not $self->directives->{TestML};
            $input .= $part;
        }
    }

    if ($top) {
        die "No TestML directive found"
            unless $self->directives->{TestML};
        die "%TestML directive must be the first (non-comment) statement"
            if $order_error;

        my $DataMarker =
            $self->directives->{DataMarker} ||=
            $self->directives->{BlockMarker};
        if ((my $split = index($input, "\n$DataMarker")) >= 0) {
            $self->{code} = substr($input, 0, $split + 1);
            $self->{data} = substr($input, $split + 1);
        }
        else {
            $self->{code} = $input;
            $self->{data} = '';
        }
    }
    else {
        $self->{text} = $input;
    }
}

1;