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   5 use TestML::Runtime;
  1         2  
  1         32  
2              
3             package TestML::Compiler;
4              
5 1     1   3 use TestML::Base;
  1         1  
  1         6  
6              
7             has code => ();
8             has data => ();
9             has text => ();
10             has directives => ();
11             has function => ();
12              
13             sub compile {
14 1     1 0 2 my ($self, $input) = @_;
15              
16 1         5 $self->preprocess($input, 'top');
17 1         4 $self->compile_code;
18 1         5 $self->compile_data;
19              
20 1 50       3 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         4 $self->function->outer(TestML::Function->new);
27 1         3 return $self->function;
28             }
29              
30             sub preprocess {
31 2     2 0 4 my ($self, $input, $top) = @_;
32              
33 2         44 my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $input;
34 2         4 $input = '';
35              
36 2         17 $self->{directives} = {
37             TestML => '',
38             DataMarker => '',
39             BlockMarker => '===',
40             PointMarker => '---',
41             };
42              
43 2         2 my $order_error = 0;
44 2         5 for my $part (@parts) {
45 25 100       41 next unless length($part);
46 19 100       46 if ($part =~ /^(\#.*|\ *)\n/) {
47 10         8 $input .= "\n";
48 10         11 next;
49             }
50 9 100       26 if ($part =~ /^%(\w+)\s*(.*?)\s*\n/) {
51 2         5 my ($directive, $value) = ($1, $2);
52 2         2 $input .= "\n";
53 2 100       8 if ($directive eq 'TestML') {
54 1 50       5 die "Invalid TestML directive"
55             unless $value =~ /^\d+\.\d+\.\d+$/;
56 1 50       5 die "More than one TestML directive found"
57             if $self->directives->{TestML};
58 1         7 $self->directives->{TestML} =
59             TestML::Str->new(value => $value);
60 1         2 next;
61             }
62 1 50       2 $order_error = 1 unless $self->directives->{TestML};
63 1 50       2 if ($directive eq 'Include') {
    0          
    0          
64 1 50       2 my $runtime = $TestML::Runtime::Singleton
65             or die "Can't process Include. No runtime available";
66 1         7 my $include = ref($self)->new;
67 1         7 $include->preprocess($runtime->read_testml_file($value));
68 1         8 $input .= $include->text;
69 1         4 $self->directives->{DataMarker} =
70             $include->directives->{DataMarker};
71 1         4 $self->directives->{BlockMarker} =
72             $include->directives->{BlockMarker};
73 1         3 $self->directives->{PointMarker} =
74             $include->directives->{PointMarker};
75 1 50       2 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 7 100 100     19 $order_error = 1 if $input and not $self->directives->{TestML};
91 7         12 $input .= $part;
92             }
93             }
94              
95 2 100       7 if ($top) {
96 1 50       4 die "No TestML directive found"
97             unless $self->directives->{TestML};
98 1 50       3 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       6 if ((my $split = index($input, "\n$DataMarker")) >= 0) {
105 1         3 $self->{code} = substr($input, 0, $split + 1);
106 1         7 $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 1         6 $self->{text} = $input;
115             }
116             }
117              
118             1;