#line 1
package TestML::Compiler;
use TestML::Mo;
use TestML::Grammar;
use TestML::AST;
use Pegex::Parser;
has base => ();
sub compile {
my $self = shift;
my $file = shift;
if (not ref $file and $file !~ /\n/) {
$file =~ s/(.*)\/(.*)/$2/ or die;
$self->base($1);
}
my $input = (not ref($file) and $file =~ /\n/)
? $file
: $self->slurp($file);
my $result = $self->preprocess($input, 'top');
my ($code, $data) = @$result{qw(code data)};
my $parser = Pegex::Parser->new(
grammar => TestML::Grammar->new,
receiver => TestML::AST->new,
);
$parser->parse($code, 'code_section')
or die "Parse TestML code section failed";
$parser = $self->fixup_grammar($parser, $result);
if (length $data) {
$parser->parse($data, 'data_section')
or die "Parse TestML data section failed";
}
if ($result->{DumpAST}) {
XXX($parser->receiver->function);
}
my $function = $parser->receiver->function;
$function->outer(TestML::Function->new());
return $function;
}
sub preprocess {
my $self = shift;
my $text = shift;
my $top = shift;
my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $text;
$text = '';
my $result = {
TestML => '',
DataMarker => '',
BlockMarker => '===',
PointMarker => '---',
};
my $order_error = 0;
for my $part (@parts) {
next unless length($part);
if ($part =~ /^(\#.*|\ *)\n/) {
$text .= "\n";
next;
}
if ($part =~ /^%(\w+)\s*(.*?)\s*\n/) {
my ($directive, $value) = ($1, $2);
$text .= "\n";
if ($directive eq 'TestML') {
die "Invalid TestML directive"
unless $value =~ /^\d+\.\d+$/;
die "More than one TestML directive found"
if $result->{TestML};
$result->{TestML} = TestML::Str->new(value => $value);
next;
}
$order_error = 1 unless $result->{TestML};
if ($directive eq 'Include') {
my $sub_result = $self->preprocess($self->slurp($value));
$text .= $sub_result->{text};
$result->{DataMarker} = $sub_result->{DataMarker};
$result->{BlockMarker} = $sub_result->{BlockMarker};
$result->{PointMarker} = $sub_result->{PointMarker};
die "Can't define %TestML in an Included file"
if $sub_result->{TestML};
}
elsif ($directive =~ /^(DataMarker|BlockMarker|PointMarker)$/) {
$result->{$directive} = $value;
}
elsif ($directive =~ /^(DebugPegex|DumpAST)$/) {
$value = 1 unless length($value);
$result->{$directive} = $value;
}
else {
die "Unknown TestML directive '$directive'";
}
}
else {
$order_error = 1 if $text and not $result->{TestML};
$text .= $part;
}
}
if ($top) {
die "No TestML directive found"
unless $result->{TestML};
die "%TestML directive must be the first (non-comment) statement"
if $order_error;
my $DataMarker = $result->{DataMarker} ||= $result->{BlockMarker};
my ($code, $data);
if ((my $split = index($text, "\n$DataMarker")) >= 0) {
$result->{code} = substr($text, 0, $split + 1);
$result->{data} = substr($text, $split + 1);
}
else {
$result->{code} = $text;
$result->{data} = '';
}
$result->{code} =~ s/^\\(\\*[\%\#])/$1/gm;
$result->{data} =~ s/^\\(\\*[\%\#])/$1/gm;
}
else {
$result->{text} = $text;
}
return $result;
}
sub fixup_grammar {
my ($self, $parser, $hash) = @_;
my $namespace = $parser->receiver->function->namespace;
$namespace->{TestML} = $hash->{TestML};
my $tree = $parser->grammar->tree;
my $point_lines = $tree->{point_lines}{'.rgx'};
my $block_marker = $hash->{BlockMarker};
if ($block_marker) {
$block_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
$tree->{block_marker}{'.rgx'} = qr/\G$block_marker/;
$point_lines =~ s/===/$block_marker/;
}
my $point_marker = $hash->{PointMarker};
if ($point_marker) {
$point_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
$tree->{point_marker}{'.rgx'} = qr/\G$point_marker/;
$point_lines =~ s/\\-\\-\\-/$point_marker/;
}
$tree->{point_lines}{'.rgx'} = qr/$point_lines/;
Pegex::Parser->new(
grammar => $parser->grammar,
receiver => $parser->receiver,
);
}
sub slurp {
my $self = shift;
my $file = shift;
my $fh;
if (ref($file)) {
$fh = $file;
}
else {
my $path = join '/', $self->base, $file;
open $fh, $path
or die "Can't open '$path' for input: $!";
}
local $/;
return <$fh>;
}
1;