File Coverage

inc/TestML/Compiler.pm
Criterion Covered Total %
statement 52 59 88.1
branch 22 38 57.8
condition 4 6 66.6
subroutine 4 4 100.0
pod 0 2 0.0
total 82 109 75.2


line stmt bran cond sub pod time code
1 1     1   6 use TestML::Runtime;
  1         1  
  1         36  
2              
3             package TestML::Compiler;
4              
5 1     1   5 use TestML::Base;
  1         2  
  1         8  
6              
7             has code => ();
8             has data => ();
9             has text => ();
10             has directives => ();
11             has function => ();
12              
13             sub compile {
14 1     1 0 3 my ($self, $input) = @_;
15              
16 1         14 $self->preprocess($input, 'top');
17 1         10 $self->compile_code;
18 1         7 $self->compile_data;
19              
20 1 50       8 if ($self->directives->{DumpAST}) {
21 0         0 XXX($self->function);
22             }
23              
24 1         4 $self->function->namespace->{TestML} = $self->directives->{TestML};
25              
26 1         5 $self->function->outer(TestML::Function->new);
27 1         4 return $self->function;
28             }
29              
30             sub preprocess {
31 14     14 0 32 my ($self, $input, $top) = @_;
32              
33 14         638 my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $input;
34 14         67 $input = '';
35              
36 14         80 $self->{directives} = {
37             TestML => '',
38             DataMarker => '',
39             BlockMarker => '===',
40             PointMarker => '---',
41             };
42              
43 14         26 my $order_error = 0;
44 14         26 for my $part (@parts) {
45 415 100       784 next unless length($part);
46 383 100       1205 if ($part =~ /^(\#.*|\ *)\n/) {
47 189         240 $input .= "\n";
48 189         251 next;
49             }
50 194 100       503 if ($part =~ /^%(\w+)\s*(.*?)\s*\n/) {
51 14         46 my ($directive, $value) = ($1, $2);
52 14         19 $input .= "\n";
53 14 100       31 if ($directive eq 'TestML') {
54 1 50       9 die "Invalid TestML directive"
55             unless $value =~ /^\d+\.\d+\.\d+$/;
56 1 50       17 die "More than one TestML directive found"
57             if $self->directives->{TestML};
58 1         8 $self->directives->{TestML} =
59             TestML::Str->new(value => $value);
60 1         4 next;
61             }
62 13 50       41 $order_error = 1 unless $self->directives->{TestML};
63 13 50       27 if ($directive eq 'Include') {
    0          
    0          
64 13 50       29 my $runtime = $TestML::Runtime::Singleton
65             or die "Can't process Include. No runtime available";
66 13         73 my $include = ref($self)->new;
67 13         48 $include->preprocess($runtime->read_testml_file($value));
68 13         41 $input .= $include->text;
69 13         35 $self->directives->{DataMarker} =
70             $include->directives->{DataMarker};
71 13         34 $self->directives->{BlockMarker} =
72             $include->directives->{BlockMarker};
73 13         29 $self->directives->{PointMarker} =
74             $include->directives->{PointMarker};
75 13 50       31 die "Can't define %TestML in an Included file"
76             if $include->directives->{TestML};
77             }
78             elsif ($directive =~ /^(DataMarker|BlockMarker|PointMarker)$/) {
79 0         0 $self->directives->{$directive} = $value;
80             }
81             elsif ($directive =~ /^(DebugPegex|DumpAST)$/) {
82 0 0       0 $value = 1 unless length($value);
83 0         0 $self->directives->{$directive} = $value;
84             }
85             else {
86 0         0 die "Unknown TestML directive '$directive'";
87             }
88             }
89             else {
90 180 100 100     569 $order_error = 1 if $input and not $self->directives->{TestML};
91 180         379 $input .= $part;
92             }
93             }
94              
95 14 100       63 if ($top) {
96 1 50       4 die "No TestML directive found"
97             unless $self->directives->{TestML};
98 1 50       5 die "%TestML directive must be the first (non-comment) statement"
99             if $order_error;
100              
101 1   33     4 my $DataMarker =
102             $self->directives->{DataMarker} ||=
103             $self->directives->{BlockMarker};
104 1 50       9 if ((my $split = index($input, "\n$DataMarker")) >= 0) {
105 1         7 $self->{code} = substr($input, 0, $split + 1);
106 1         21 $self->{data} = substr($input, $split + 1);
107             }
108             else {
109 0         0 $self->{code} = $input;
110 0         0 $self->{data} = '';
111             }
112             }
113             else {
114 13         86 $self->{text} = $input;
115             }
116             }
117              
118             1;